diff options
Diffstat (limited to 'ipl/procs')
249 files changed, 45861 insertions, 0 deletions
diff --git a/ipl/procs/abkform.icn b/ipl/procs/abkform.icn new file mode 100644 index 0000000..82990ae --- /dev/null +++ b/ipl/procs/abkform.icn @@ -0,0 +1,532 @@ +############################################################################ +# +# File: abkform.icn +# +# Subject: Procedures to process HP95LX appointment books +# +# Author: Robert J. Alexander +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Procedures set to read and write HP95LX appointment book (.abk) files. +# +# +# Notes: +# +# 1. Files created by the Appointment Book application may contain +# some padding following the last field of some data records. Hence, +# the RecordLength field must be used to determine the start of the +# next record. Appointment book files created by other programs need not +# have any padding. +# +# 2. ApptState has several bit fields. Only bit 0 is meaningful to software +# processing an appointment book file. Bit 0 being set or cleared +# corresponds to the alarm being enabled or disabled, respectively. +# Programs creating Appointment book files should clear all bits, except +# perhaps bit 0. +# +# 3. ToDoState has two one-bit bit fields. Bit 0 being set or cleared +# corresponds to carry forward being enabled or disabled for this todo +# item, respectively. Bit 1 being set or cleared corresponds to the doto +# being checked off or not checked off, respectively. +# +# 4. Appointment and ToDo texts are each limited to a maximum of 27 +# characters. +# +# 5. Note text is limited to a maximum of 11 lines of 39 characters per line +# (not counting the line terminator). +# +# +############################################################################ +# +# Links: bkutil, pbkform +# +############################################################################ +# +# See also: bkutil.icn, pbkform.icn +# +############################################################################ + +link bkutil, pbkform + +# HP 95LX Appointment Book File Format +# +# The HP 95LX Appointment Book file is structured as a file-identification +# record, followed by a settings record, followed by a variable number of data +# records, and terminated by an end-of-file record. There are multiple types of +# data records corresponding to the different types of appointment book entries. +# +# The formats of these appointment book records is described in the following +# tables. In the descriptions, the type <int> refers to a two-byte integer +# stored least significant byte first, the type <swpint> refers to a two-byte +# integer stored most significant byte first, the type <char> refers to a +# one-byte integer, and the type <ASCII> refers to a string of ASCII +# characters. +# +# HP 95LX Appointment Book File Identification Record: +# +# Byte Offset Name Type Contents +# +# 0 ProductCode int -1 (FFh, FFh) +# 2 ReleaseNum int 1 (01h, 00h) +# 4 FileType char 1 (01h) +# +procedure abk_write_id(f) + return writes(f,"\xff\xff\x01\x00\x01") +end + +record abk_id(releaseNum,filetype) + +procedure abk_read_id(f) + bk_read_int(f) = 16rffff | fail + return pbk_id(bk_read_int(f),ord(reads(f))) +end + +# +# HP 95LX Appointment Book Settings Record: +# +# Byte Offset Name Type Contents +# +# 0 StartTime int Daily display start time as the +# number of minutes past midnight. +# 2 Granularity int Daily display time line granularity +# in minutes. +# 4 AlarmEnable char 1 = on, 0 = off +# 5 LeadTime char Alarm default lead time in minutes. +# 6 CarryForward char To do carry forward default, +# 1 = on, 0 = off. +# +record abk_settings(startTime,granularity,alarmEnable,leadTime,carryForward) + +procedure abk_write_settings(f,data) + return writes(f,bk_int(data.startTime),bk_int(data.granularity), + char(data.alarmEnable), char(data.leadTime),char(data.carryForward)) +end + +procedure abk_read_settings(f) + return abk_settings(bk_read_int(f),bk_read_int(f),ord(reads(f)), + ord(reads(f)),ord(reads(f))) +end + +# +# +# HP 95LX Appointment Book Daily Data Record: +# +# Byte Offset Name Type Contents +# +# 0 RecordType char 1 (01h) +# 1 RecordLength int Number of bytes in remainder +# of this data record, see note 1 +# below. +# 3 ApptState char See note 2 below. +# 4 Year char Year counting from 1900. +# 5 Month char Month, 1 - 12. +# 6 Day char Day, 1 - 31. +# 7 StartTime swpint Start time in minutes since midnight. +# 9 EndTime int End time in minutes since midnight. +# 11 LeadTime char Alarm lead time in minutes, 0 - 30. +# 12 ApptLength char Length of appointment text in bytes. +# 13 NoteLength int Length of note text in bytes. +# 15 ApptText ASCII Appointment text - see note 4 below. +# 15+ApptLength NoteText ASCII Note text where the null character +# is used as the line terminator - +# see note 5. +# +record abk_daily(alarmEnable,year,month,day,startTime,endTime,leadTime, + apptText,noteText) + +procedure abk_write_daily(f,data) + writes(char((\data.alarmEnable,1) | 0), + char(data.year),char(data.month),char(data.day), + bk_int(data.startTime),bk_int(data.endTime),bk_int(data.leadTime), + char(*data.apptText),char(*data.noteText),data.apptText,data.noteText) + return data +end + +procedure abk_read_daily(f) + local alarmEnable,year,month,day,startTime,endTime,leadTime, + apptText,noteText,apptLength,noteLength,next_rec + (reads(f) == "\x01" | (seek(f,where(f) - 1),&fail) & + next_rec := bk_read_int(f) + where(f) & + alarmEnable := iand(ord(reads(f)),1) = 1 | &null & + year := ord(reads(f)) & + month := ord(reads(f)) & + day := ord(reads(f)) & + startTime := bk_read_int(f) & + endTime := bk_read_int(f) & + leadTime := ord(reads(f)) & + apptLength := ord(reads(f)) & + noteLength := bk_read_int(f) & + apptText := reads(f,apptLength) & + noteText := reads(f,noteLength)) | fail + return abk_daily(alarmEnable,year,month,day,startTime,endTime,leadTime, + apptText,noteText) +end + +# +# HP 95LX Appointment Book Weekly Data Record: +# +# Byte Offset Name Type Contents +# +# 0 RecordType char 2 (02h) +# 1 RecordLength int Number of bytes in remainder +# of this data record, see note 1 +# below. +# 3 ApptState char See note 2 below. +# 4 DayOfWeek char Day of week, 1=Sun, ..., 7=Sat. +# 5 StartTime swpint Start time in minutes since midnight. +# 7 StartYear char Start year counting from 1900. +# 8 StartMonth char Start month, 1 - 12. +# 9 StartDay char Start day, 1 - 31. +# 10 EndTime int End time in minutes since midnight. +# 12 EndYear char End year counting from 1900. +# 13 EndMonth char End month, 1 - 12. +# 14 EndDay char End day, 1 - 31. +# 15 LeadTime char Alarm lead time in minutes, 0 - 30. +# 16 ApptLength char Length of appointment text in bytes. +# 17 NoteLength int Length of note text in bytes. +# 19 ApptText ASCII Appointment text - see note 4 below. +# 19+ApptLength NoteText ASCII Note text where the null character +# is used as the line terminator - +# see note 5 below. +# +record abk_weekly(alarmEnable,dayOfWeek,startTime,startYear,startMonth,startDay, + endTime,endYear,endMonth,endDay,leadTime,apptText,noteText) + +procedure abk_write_weekly(f,data) + writes(char((\data.alarmEnable,1) | 0), + char(data.dayOfWeek), + bk_int(data.startTime),char(data.startYear), + char(data.startMonth),char(data.startDay), + bk_int(data.endTime),char(data.endYear), + char(data.endMonth),char(data.endDay), + bk_int(data.leadTime), + char(*data.apptText),char(*data.noteText),data.apptText,data.noteText) + return data +end + +procedure abk_read_weekly(f) + local alarmEnable,dayOfWeek,startTime,startYear,startMonth,startDay, + endTime,endYear,endMonth,endDay,leadTime,apptLength,noteLength, + apptText,noteText,next_rec + (reads(f) == "\x02" | (seek(f,where(f) - 1),&fail) & + next_rec := bk_read_int(f) + where(f) & + alarmEnable := iand(ord(reads(f)),1) = 1 | &null & + dayOfWeek := ord(reads(f)) & + startTime := bk_read_int(f) & + startYear := ord(reads(f)) & + startMonth := ord(reads(f)) & + startDay := ord(reads(f)) & + endTime := bk_read_int(f) & + endYear := ord(reads(f)) & + endMonth := ord(reads(f)) & + endDay := ord(reads(f)) & + leadTime := ord(reads(f)) & + apptLength := ord(reads(f)) & + noteLength := bk_read_int(f) & + apptText := reads(f,apptLength) & + noteText := reads(f,noteLength)) | fail + return abk_daily(alarmEnable,dayOfWeek,startTime,startYear,startMonth, + startDay,endTime,endYear,endMonth,endDay,leadTime,apptText,noteText) +end + +# +# +# HP 95LX Appointment Book Monthly by Date Data Record: +# +# Byte Offset Name Type Contents +# +# 0 RecordType char 3 (03h) +# 1 RecordLength int Number of bytes in remainder +# of this data record, see note 1 +# below. +# 3 ApptState char See note 2 below. +# 4 DayOfMonth char Day of month, 1 - 31. +# 5 StartTime swpint Start time in minutes since midnight. +# 7 StartYear char Start year counting from 1900. +# 8 StartMonth char Start month, 1 - 12. +# 9 StartDay char Start day, 1 - 31. +# 10 EndTime int End time in minutes since midnight. +# 12 EndYear char End year counting from 1900. +# 13 EndMonth char End month, 1 - 12. +# 14 EndDay char End day, 1 - 31. +# 15 LeadTime char Alarm lead time in minutes, 0 - 30. +# 16 ApptLength char Length of appointment text in bytes. +# 17 NoteLength int Length of note text in bytes. +# 19 ApptText ASCII Appointment text - see note 4 below. +# 19+ApptLength NoteText ASCII Note text where the null character +# is used as the line terminator - +# see note 5 below. +# +record abk_monthly(alarmEnable,dayOfMonth,startTime,startYear,startMonth, + startDay,endTime,endYear,endMonth,endDay,leadTime,apptText,noteText) + +procedure abk_write_monthly(f,data) + writes(char((\data.alarmEnable,1) | 0), + char(data.dayOfMonth), + bk_int(data.startTime),char(data.startYear), + char(data.startMonth),char(data.startDay), + bk_int(data.endTime),char(data.endYear), + char(data.endMonth),char(data.endDay), + bk_int(data.leadTime), + char(*data.apptText),char(*data.noteText),data.apptText,data.noteText) + return data +end + +procedure abk_read_monthly(f) + local alarmEnable,dayOfMonth,startTime,startYear,startMonth,startDay, + endTime,endYear,endMonth,endDay,leadTime,apptLength,noteLength, + apptText,noteText,next_rec + (reads(f) == "\x03" | (seek(f,where(f) - 1),&fail) & + next_rec := bk_read_int(f) + where(f) & + alarmEnable := iand(ord(reads(f)),1) = 1 | &null & + dayOfMonth := ord(reads(f)) & + startTime := bk_read_int(f) & + startYear := ord(reads(f)) & + startMonth := ord(reads(f)) & + startDay := ord(reads(f)) & + endTime := bk_read_int(f) & + endYear := ord(reads(f)) & + endMonth := ord(reads(f)) & + endDay := ord(reads(f)) & + leadTime := ord(reads(f)) & + apptLength := ord(reads(f)) & + noteLength := bk_read_int(f) & + apptText := reads(f,apptLength) & + noteText := reads(f,noteLength)) | fail + return abk_daily(alarmEnable,dayOfMonth,startTime,startYear,startMonth, + startDay,endTime,endYear,endMonth,endDay,leadTime,apptText,noteText) +end + +# +# HP 95LX Appointment Book Monthly by Position Data Record: +# +# Byte Offset Name Type Contents +# +# 0 RecordType char 4 (04h) +# 1 RecordLength int Number of bytes in remainder +# of this data record, see note 1 +# below. +# 3 ApptState char See note 2 below. +# 4 WeekOfMonth char Week of month, 1 - 5. +# 5 DayOfWeek char Day of week, 1=Sun, ..., 7=Sat. +# 6 StartTime swpint Start time in minutes since midnight. +# 8 StartYear char Start year counting from 1900. +# 9 StartMonth char Start month, 1 - 12. +# 10 StartDay char Start day, 1 - 31. +# 11 EndTime int End time in minutes since midnight. +# 13 EndYear char End year counting from 1900. +# 14 EndMonth char End month, 1 - 12. +# 15 EndDay char End day, 1 - 31. +# 16 LeadTime char Alarm lead time in minutes, 0 - 30. +# 17 ApptLength char Length of appointment text in bytes. +# 18 NoteLength int Length of note text in bytes. +# 20 ApptText ASCII Appointment text - see note 4 below. +# 20+ApptLength NoteText ASCII Note text where the null character +# is used as the line terminator - +# see note 5 below. +# +record abk_monthly_pos(alarmEnable,weekOfMonth,dayOfWeek,startTime,startYear, + startMonth,startDay,endTime,endYear,endMonth,endDay,leadTime, + apptText,noteText) + +procedure abk_write_monthly_pos(f,data) + writes(char((\data.alarmEnable,1) | 0), + char(data.weekOfMonth), + char(data.dayOfWeek), + bk_int(data.startTime),char(data.startYear), + char(data.startMonth),char(data.startDay), + bk_int(data.endTime),char(data.endYear), + char(data.endMonth),char(data.endDay), + bk_int(data.leadTime), + char(*data.apptText),char(*data.noteText),data.apptText,data.noteText) + return data +end + +procedure abk_read_monthly_pos(f) + local alarmEnable,weekOfMonth,dayOfWeek,startTime,startYear,startMonth, + startDay,endTime,endYear,endMonth,endDay,leadTime,apptLength,noteLength, + apptText,noteText,next_rec + (reads(f) == "\x04" | (seek(f,where(f) - 1),&fail) & + next_rec := bk_read_int(f) + where(f) & + alarmEnable := iand(ord(reads(f)),1) = 1 | &null & + weekOfMonth := ord(reads(f)) & + dayOfWeek := ord(reads(f)) & + startTime := bk_read_int(f) & + startYear := ord(reads(f)) & + startMonth := ord(reads(f)) & + startDay := ord(reads(f)) & + endTime := bk_read_int(f) & + endYear := ord(reads(f)) & + endMonth := ord(reads(f)) & + endDay := ord(reads(f)) & + leadTime := ord(reads(f)) & + apptLength := ord(reads(f)) & + noteLength := bk_read_int(f) & + apptText := reads(f,apptLength) & + noteText := reads(f,noteLength)) | fail + return abk_daily(alarmEnable,weekOfMonth,dayOfWeek,startTime,startYear, + startMonth,startDay,endTime,endYear,endMonth,endDay,leadTime,apptText, + noteText) +end + +# +# HP 95LX Appointment Book Yearly Data Record: +# +# Byte Offset Name Type Contents +# +# 0 RecordType char 5 (05h) +# 1 RecordLength int Number of bytes in remainder +# of this data record, see note 1 +# below. +# 3 ApptState char See note 2 below. +# 4 MonthOfYear char Month of year, 1=Jan, ... 12=Dec. +# 5 DayOfMonth char Day of month, 1 - 31. +# 6 StartTime swpint Start time in minutes since midnight. +# 8 StartYear char Start year counting from 1900. +# 9 StartMonth char Start month, 1 - 12. +# 10 StartDay char Start day, 1 - 31. +# 11 EndTime int End time in minutes since midnight. +# 13 EndYear char End year counting from 1900. +# 14 EndMonth char End month, 1 - 12. +# 15 EndDay char End day, 1 - 31. +# 16 LeadTime char Alarm lead time in minutes, 0 - 30. +# 17 ApptLength char Length of appointment text in bytes. +# 18 NoteLength int Length of note text in bytes. +# 20 ApptText ASCII Appointment text - see note 4 below. +# 20+ApptLength NoteText ASCII Note text where the null character +# is used as the line terminator - +# see note 5 below. +# +record abk_yearly(alarmEnable,monthOfYear,dayOfMonth,startTime,startYear, + startMonth,startDay,endTime,endYear,endMonth,endDay,leadTime, + apptText,noteText) + +procedure abk_write_yearly(f,data) + writes(char((\data.alarmEnable,1) | 0), + char(data.monthOfYear), + char(data.dayOfMonth), + bk_int(data.startTime),char(data.startYear), + char(data.startMonth),char(data.startDay), + bk_int(data.endTime),char(data.endYear), + char(data.endMonth),char(data.endDay), + bk_int(data.leadTime), + char(*data.apptText),char(*data.noteText),data.apptText,data.noteText) + return data +end + +procedure abk_read_yearly(f) + local alarmEnable,monthOfYear,dayOfMonth,startTime,startYear,startMonth, + startDay,endTime,endYear,endMonth,endDay,leadTime,apptLength,noteLength, + apptText,noteText,next_rec + (reads(f) == "\x05" | (seek(f,where(f) - 1),&fail) & + next_rec := bk_read_int(f) + where(f) & + alarmEnable := iand(ord(reads(f)),1) = 1 | &null & + monthOfYear := ord(reads(f)) & + dayOfMonth := ord(reads(f)) & + startTime := bk_read_int(f) & + startYear := ord(reads(f)) & + startMonth := ord(reads(f)) & + startDay := ord(reads(f)) & + endTime := bk_read_int(f) & + endYear := ord(reads(f)) & + endMonth := ord(reads(f)) & + endDay := ord(reads(f)) & + leadTime := ord(reads(f)) & + apptLength := ord(reads(f)) & + noteLength := bk_read_int(f) & + apptText := reads(f,apptLength) & + noteText := reads(f,noteLength)) | fail + return abk_daily(alarmEnable,monthOfYear,dayOfMonth,startTime,startYear, + startMonth,startDay,endTime,endYear,endMonth,endDay,leadTime,apptText, + noteText) +end + +# +# HP 95LX Appointment Book To Do Data Record: +# +# Byte Offset Name Type Contents +# +# 0 RecordType char 6 (06h) +# 1 RecordLength int Number of bytes in remainder +# of this data record, see note 1 +# below. +# 3 ToDoState char See note 3 below. +# 4 Priority char Priority, 1 - 9. +# 5 StartYear char Start year counting from 1900. +# 6 StartMonth char Start month, 1 - 12. +# 7 StartDay char Start day, 1 - 31. +# 8 CheckOffYear char Check off year counting from 1900, +# 0 indicates not checked off. +# 9 CheckOffMonth char Check off month, 1 - 12, +# 0 indicates not checked off. +# 10 CheckOffDay char Check off day, 1 - 31, +# 0 indicates not checked off. +# 11 ToDoLength char Length of to do text in bytes. +# 12 NoteLength int Length of note text in bytes. +# 14 ToDoText ASCII To do text - see note 4 below. +# 14+ToDoLength NoteText ASCII Note text where the null character +# is used as the line terminator - +# see note 5 below. +# +record abk_todo(carryForward,checkOff,priority,startYear,startMonth, + startDay,CheckOffYear,CheckOffMonth,CheckOffDay,toDoText,toDoNote) + +procedure abk_write_todo(f,data) + writes(char(ior((\data.carryForward,1) | 0,(\data.checkOff,2) | 0)), + char(data.priority), + char(data.startYear), + char(data.startMonth),char(data.startDay), + char(data.checkOffYear), + char(data.checkOffMonth),char(data.checkOffDay), + char(*data.toDoText),char(*data.noteText),data.toDoText,data.noteText) + return data +end + +procedure abk_read_todo(f) + local carryForward,checkOff,priority,startYear,startMonth, + startDay,CheckOffYear,CheckOffMonth,CheckOffDay,toDoLength,noteLength, + toDoText,toDoNote,toDoState,next_rec + (reads(f) == "\x06" | (seek(f,where(f) - 1),&fail) & + next_rec := bk_read_int(f) + where(f) & + toDoState := ord(reads(f)) & + carryForward := iand(toDoState,1) = 1 | &null & + checkOff := iand(toDoState,2) = 1 | &null & + priority := ord(reads(f)) & + startYear := ord(reads(f)) & + startMonth := ord(reads(f)) & + startDay := ord(reads(f)) & + CheckOffYear := ord(reads(f)) & + CheckOffMonth := ord(reads(f)) & + CheckOffDay := ord(reads(f)) & + toDoLength := ord(reads(f)) & + noteLength := bk_read_int(f) & + toDoText := reads(f,toDoLength) & + toDoNote := reads(f,noteLength)) | fail + return abk_daily(carryForward,checkOff,priority,startYear,startMonth, + startDay,CheckOffYear,CheckOffMonth,CheckOffDay,toDoText,toDoNote) +end + +# +# HP 95LX Appointment Book End of File Record: +# +# Byte Offset Name Type Contents +# +# 0 RecordType char 50 (32h) +# 1 RecordLength int 0 (00h, 00h) +# +procedure abk_write_end(f) + writes(f,"\x32\x00\x00") + return +end + +procedure abk_read_end(f,id) + (reads(f) == "\x32" & reads(f,2)) | fail + return +end diff --git a/ipl/procs/adjuncts.icn b/ipl/procs/adjuncts.icn new file mode 100644 index 0000000..ba05c9e --- /dev/null +++ b/ipl/procs/adjuncts.icn @@ -0,0 +1,112 @@ +############################################################################ +# +# File: adjuncts.icn +# +# Subject: Procedures for gettext and idxtext +# +# Author: Richard L. Goerwitz +# +# Date: June 21, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.4 December 28, 1993 Phillip Lee Thomas +# _delimiter added to global list. +# OS conventions moved to Set_OS() from +# idxtext.icn and gettext.icn. +# Version: 1.5 August 5, 1995 Add MS-DOS/386 to features check. +# +############################################################################ +# +# Pretty mundane stuff. Set_OS(), Basename(), Pathname(), Strip(), and +# a utility for creating index filenames. +# +############################################################################ +# +# See also: gettext.icn, idxtext,icn +# +############################################################################ + + +global _slash, _baselen, _delimiter, _OS_offset, firstline + +procedure Set_OS() #: set global OS features + + # delimiter for indexed values + _delimiter := char(255) + + # Initialize filename and line termination conventions. + # _baselen: number of characters in filename base. + # _OS_offset: number of characters marking newline. + + if find("UNIX"|"Amiga", &features) then { + _slash := "/" + _baselen := 10 + _OS_offset := 1 + } + else if find("MS-DOS"|"MS-DOS/386"|"OS/2"|"MS Windows NT", &features) then { + _slash := "\\" + _baselen := 8 + _OS_offset := 2 + } + else if find("Macintosh", &features) then { + _slash := ":" + _baselen := 15 + _OS_offset := 1 + } + else stop("gettext: OS not supported") + return +end + +procedure Basename(s) #: obtain base filename + + # global _slash + s ? { + while tab(find(_slash)+1) + return tab(0) + } +end + + +procedure Pathname(s) #: obtain path of filename + + local s2 + # global _slash + + s2 := "" + s ? { + while s2 ||:= tab(find(_slash)+1) + return s2 + } +end + + +procedure getidxname(FNAME) #: obtain index from datafile name + + # + # Discard path component. Cut basename down to a small enough + # size that the OS will be able to handle addition of the ex- + # tension ".IDX" + # + + # global _slash, _baselen + return right(Strip(Basename(FNAME,_slash),'.'), _baselen, "x") || ".IDX" +end + + +procedure Strip(s,c) #: remove chars from string + + local s2 + + s2 := "" + s ? { + while s2 ||:= tab(upto(c)) + do tab(many(c)) + s2 ||:= tab(0) + } + return s2 +end diff --git a/ipl/procs/adlutils.icn b/ipl/procs/adlutils.icn new file mode 100644 index 0000000..577c944 --- /dev/null +++ b/ipl/procs/adlutils.icn @@ -0,0 +1,177 @@ +############################################################################ +# +# File: adlutils.icn +# +# Subject: Procedures to process address lists +# +# Author: Ralph E. Griswold +# +# Date: January 3, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Procedures used by programs that process address lists: +# +# nextadd() get next address +# writeadd(add) write address +# get_country(add) get country +# get_state(add) get state (U.S. addresses only) +# get_city(add) get city (U.S. addresses only) +# get_zipcode(add) get ZIP code (U.S. addresses only) +# get_lastname(add) get last name +# get_namepfx(add) get name prefix +# get_title(add) get name title +# format_country(s) format country name +# +############################################################################ +# +# Links: lastname, io, namepfx, title +# +############################################################################ + +link lastname, io, namepfx, title + +record label(header, text, comments) + +procedure nextadd() + local comments, header, line, text + + initial { # Get to first label. + while line := Read() do + line ? { + if ="#" then { + PutBack(line) + break + } + } + } + + header := Read() | fail + + comments := text := "" + + while line := Read() do + line ? { + if pos(0) then next # Skip empty lines. + else if ="*" then comments ||:= "\n" || line + else if ="#" then { # Header for next label. + PutBack(line) + break # Done with current label. + } + else text ||:= "\n" || line + } + every text | comments ?:= { # Strip off leading newline, if any. + move(1) + tab(0) + } + + return label(header, text, comments) + +end + +procedure writeadd(add) + + if *add.text + *add.comments = 0 then return + write(add.header) + if *add.text > 0 then write(add.text) + if *add.comments > 0 then write(add.comments) + + return + +end + +procedure get_country(add) + + trim(add.text) ? { + while tab(upto('\n')) do move(1) + if tab(0) ? { + tab(-1) + any(&digits) + } then return "U.S.A." + else return tab(0) + } +end + +procedure get_state(add) + + trim(add.text) ? { + while tab(upto('\n')) do move(1) + ="APO" + while tab(upto(',')) do move(1) + tab(many(' ')) + return (tab(any(&ucase)) || tab(any(&ucase))) | "XX" + } + +end + +procedure get_city(add) # only works for U.S. addresses + local result + + result := "" + trim(add.text) ? { + while tab(upto('\n')) do move(1) + result := ="APO" + result ||:= tab(upto(',')) + return result + } + +end + + + +procedure get_zipcode(add) + local zip + + trim(add.text) ? { + while tab(upto('\n')) do move(1) # get to last line + while tab(upto(' ')) do tab(many(' ')) # get to last field + zip := tab(0) + if *zip = 5 & integer(zip) then return zip + else if *zip = 10 & zip ? { + integer(move(5)) & ="-" & integer(tab(0)) + } + then return zip + else return "9999999999" # "to the end of the universe" + } + +end + +procedure get_lastname(add) + + return lastname(add.text ? tab(upto('\n') | 0)) + +end + +procedure get_namepfx(add) + + return namepfx(add.text ? tab(upto('\n') | 0)) + +end + +procedure get_title(add) + + return title(add.text ? tab(upto('\n') | 0)) + +end + +procedure format_country(s) + local t, word + + s := map(s) + t := "" + s ? while tab(upto(&lcase)) do { + word := tab(many(&lcase)) + if word == "of" then t ||:= word + else t ||:= { + word ? { + map(move(1),&lcase,&ucase) || tab(0) + } + } + t ||:= move(1) + } + return t +end diff --git a/ipl/procs/allof.icn b/ipl/procs/allof.icn new file mode 100644 index 0000000..1a2003c --- /dev/null +++ b/ipl/procs/allof.icn @@ -0,0 +1,112 @@ +############################################################################ +# +# File: allof.icn +# +# Subject: Procedure for conjunction control operation +# +# Author: Robert J. Alexander +# +# Date: April 28, 1990 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# allof{expr1,expr2} -- Control operation that performs iterative +# conjunction. +# +# Iterative conjunction permits a conjunction expression to be built +# at run time which supports full backtracking among the created terms +# of the expression. The computed expression can be of arbitrary +# length, and is built via an iterative loop in which one term is +# appended to the expression (as if connected with a "&" operator) per +# iteration. +# +# Expr1 works like the control expression of "every-do"; it controls +# iteration by being resumed to produce all of its possible results. +# The allof{} expression produces the outcome of conjunction of all of +# the resulting instances of expr2. +# +# For example: +# +# global c +# ... +# pattern := "ab*" +# "abcdef" ? { +# allof { c := !pattern , +# if c == "*" then move(0 to *&subject - &pos + 1) else =c +# } & pos(0) +# } +# +# This example will perform a wild card match on "abcdef" against +# pattern "ab*", where "*" in a pattern matches 0 or more characters. +# Since pos(0) will fail the first time it is evaluated, the allof{} +# expression will be resumed just as a conjunction expression would, +# and backtracking will propagate through all of the instances of +# expr2; the expression will ultimately succeed (as its conjunctive +# equivalent would). +# +# Note that, due to the scope of variables in co-expressions, +# variables shared between expr1 and expr2 must have global scope, +# hence c in the above example must be global. +# +# The allof{} procedure models Icon's expression evaluation +# mechanism in that it explicitly performs backtracking. The author of +# this procedure knows of no way to invoke Icon's built-in goal +# directed evaluation to perform conjunction of a arbitrary number of +# computed expressions (suggestions welcome). +# +############################################################################ +# +# Requires: co-expressions +# +############################################################################ + +procedure allof(expr) + local elist,i,x,v + # + # Initialize + # + elist := [] # expression list + i := 1 # expression list index + + # + # Loop until backtracking over all expr[2]s has failed. + # + while i > 0 do { + if not (x := elist[i]) then + # + # If we're at the end of the list of expressions, attempt an + # iteration to produce another expression. + # + if @expr[1] then + put(elist,x := ^expr[2]) + else { + # + # If no further iterations, suspend a result. + # + suspend v + # + # We've been backed into -- reset to last expr[2]. + # + i -:= 1 + } + # + # Evaluate the expression. + # + if v := @\x then { + # + # If success, move on to the refreshed next expression. + # + i +:= 1 + elist[i] := ^elist[i] + } + else + # + # If failure, back up. + # + i -:= 1 + } +end diff --git a/ipl/procs/allpat.icn b/ipl/procs/allpat.icn new file mode 100644 index 0000000..8f50979 --- /dev/null +++ b/ipl/procs/allpat.icn @@ -0,0 +1,35 @@ +############################################################################ +# +# File: allpat.icn +# +# Subject: Procedure to produce all n-character patterns of characters +# +# Author: Ralph E. Griswold +# +# Date: May 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# +# +############################################################################ +# +# Requires: +# +############################################################################ +# +# Links: +# +############################################################################ + +procedure allpat(s, i) + + if i = 0 then return "" + + suspend !s || allpat(s, i - 1) + +end diff --git a/ipl/procs/ansi.icn b/ipl/procs/ansi.icn new file mode 100644 index 0000000..02b2f6d --- /dev/null +++ b/ipl/procs/ansi.icn @@ -0,0 +1,221 @@ +############################################################################ +# +# File: ansi.icn +# +# Subject: Procedures for ANSI-based terminal control +# +# Authors: Ralph E. Griswold and Richard Goerwitz +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.5 +# +############################################################################ +# +# This package of procedures implements a subset of the ANSI terminal +# control sequences. The names of the procedures are taken directly from +# the ANSI names. If it is necessary to use these routines with non-ANSI +# devices, link in iolib.icn, and (optionally) iscreen.icn as well. Use +# will be made of whatever routines are made available via either of these +# libraries. Be careful of naming conflicts if you link in iscreen.icn. +# It contains procedures like "clear" and "boldface." +# +# CUB(i) Moves the cursor left i columns +# CUD(i) Moves the cursor down i rows +# CUF(i) Moves the cursor right i columns +# CUP(i,j) Moves the cursor to row i, column j +# CUU(i) Moves the cursor up i rows +# ED(i) Erases screen: i = 0, cursor to end; i = 1, +# beginning to cursor; i = 2, all (default 2) +# EL(i) Erases data in cursor row: i = 0, cursor to +# end; i = 1, beginning to cursor; i = 2, all +# (default 0) +# SGR(i) Sets video attributes: 0 = off; 1 = bold; 4 = +# underscore; 5 = blink; 7 = reverse (default +# 0) +# +# Note that not all so-called ANSI terminals support every ANSI +# screen control sequence - not even the limited subset included in +# this file. +# +# If you plan on using these routines with non-ANSI magic-cookie +# terminals (e.g. a Wyse-50) then it is strongly recommended that you +# link in iolib or itlib *and* iscreen (not just iolib or itlib by +# itself). The routines WILL WORK with most magic cookie terminals; +# they just don't always get all the modes displayed (because they +# are basically too busy erasing the cookies). +# +############################################################################ +# +# Links: iolib or itlib, iscreen (all optional) +# +############################################################################ + +# For DOS, or any system using ANSI-conformant output devices, there +# is no need to link any routines in. + +# For UNIX systems, you may choose to link in itlib or iolib, and (if +# desired) iscreen as well. Some of these may be in the IPL. You can +# get any that aren't from Richard Goerwitz (goer@sophist.uchicago.edu). + +invocable all + +link iolib + +procedure _isANSI() + static isANSI + initial { + if find("MS-DOS",&features) then { + isANSI := 1 + } else { + if proc(getname) then { + if find("ansi",map(getname())) | getname() == "li" + then isANSI := 1 + else isANSI := &null + } else { + # We'll take a chance on the user knowing what he/she + # is doing. + isANSI := 1 + # If you're not so confident, comment out the following + # line: + # stop("_isANSI: you need to link itlib or iolib") + } + } + } + return \isANSI +end + +procedure CUD(i) + if _isANSI() + then writes("\^[[",i,"B") + else { + iputs(igoto(getval("DO"),i)) | { + every 1 to i do + iputs(getval("do")) | stop("CUD: no do capability") + } + } + return +end + +procedure CUB(i) + if _isANSI() + then writes("\^[[",i,"D") + else { + iputs(igoto(getval("LE"),i)) | { + every 1 to i do + iputs(getval("le")) | stop("CUB: no le capability") + } + } + return +end + +procedure CUF(i) + if _isANSI() + then writes("\^[[",i,"C") + else { + iputs(igoto(getval("RI"),i)) | { + every 1 to i do + iputs(getval("nd")) | stop("CUF: no nd capability") + } + } + return +end + +procedure CUP(i,j) + if _isANSI() + then writes("\^[[",i,";",j,"H") + else iputs(igoto(getval("cm"), j, i)) | stop("CUP: no cm capability") + return +end + +procedure CUU(i) + if _isANSI() + then writes("\^[[",i,"A") + else { + iputs(igoto(getval("UP"),i)) | { + every 1 to i do + iputs(getval("up")) | stop("CUU: no up capability") + } + } + return +end + +procedure ED(i) + local emphasize, clear + + /i := 2 + if _isANSI() then { + writes("\^[[",i,"J") + } else { + case i of { + 0: iputs(getval("cd")) | stop("ED: no cd capability") + 1: stop("ED: termcap doesn't specify capability") + 2: { + if proc(emphasize) then clear() + else iputs(getval("cl")) | stop("ED: no cl capability") + } + default: stop("ED: unknown clear code, ",i) + } + } + return +end + +procedure EL(i) + /i := 0 + if _isANSI() then { + if i = 0 + then writes("\^[[K") + else writes("\^[[",i,"K") + } else { + case i of { + 0: iputs(getval("ce")) | stop("EL: no ce capability") + 1: stop("EL: termcap doesn't specify capability") + 2: stop("EL: try using CUP to go to col 1, then EL(0)") + default: stop("EL: unknown line clear code, ",i) + } + } + return +end + +procedure SGR(i) + + local emphasize, normal, boldface, underline, blink + + static isISCR + + initial { + if proc(emphasize) + then isISCR := 1 + } + + /i := 0 + if _isANSI() then { + writes("\^[[",i,"m") + } else { + case i of { + 0: (\isISCR, normal()) | { + every iputs(getval("me"|"se"|"ue")) + } + 1: (\isISCR, boldface()) | { + iputs(getval("md"|"so"|"us")) + } + 4: (\isISCR, underline()) | { + iputs(getval("us"|"md"|"so")) + } + 5: (\isISCR, blink()) | { + iputs(getval("mb"|"us"|"md"|"so")) + } + 7: (\isISCR, emphasize()) | { + iputs(getval("so"|"md"|"us")) + } + default: stop("SGR: unknown mode, ",i) + } + } + return +end diff --git a/ipl/procs/apply.icn b/ipl/procs/apply.icn new file mode 100644 index 0000000..a275899 --- /dev/null +++ b/ipl/procs/apply.icn @@ -0,0 +1,38 @@ +############################################################################ +# +# File: apply.icn +# +# Subject: Procedure to apply a list of functions to an argument +# +# Author: Ralph E. Griswold +# +# Date: March 4, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure applies a list of functions to an argument. An example is +# +# apply([integer, log], 10) +# +# which is equivalent to integer(log(10)). +# +# +############################################################################ + +procedure apply(plist, arg) + local p + + plist := copy(plist) + + p := get(plist) | fail + + if *plist = 0 then + suspend p(arg) + else + suspend p(apply(plist, arg)) + +end diff --git a/ipl/procs/argparse.icn b/ipl/procs/argparse.icn new file mode 100644 index 0000000..f6ae81a --- /dev/null +++ b/ipl/procs/argparse.icn @@ -0,0 +1,39 @@ +############################################################################ +# +# File: argparse.icn +# +# Subject: Procedure to parse pseudo-command-line +# +# Author: Ralph E. Griswold +# +# Date: November 14, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# argparse(s) parses s as if it were a command line and puts the components in +# in a list, which is returned. +# +# At present, it does not accept any escape conventions. +# +############################################################################ + +procedure argparse(s) + local arglist + static nonblank + + initial nonblank := &cset -- ' \t\n' + + arglist := [] + + s ? { + while tab(upto(nonblank)) do + put(arglist, tab(many(nonblank))) + } + + return arglist + +end diff --git a/ipl/procs/array.icn b/ipl/procs/array.icn new file mode 100644 index 0000000..442f73f --- /dev/null +++ b/ipl/procs/array.icn @@ -0,0 +1,69 @@ +############################################################################ +# +# File: array.icn +# +# Subject: Procedures for n-dimensional arrays +# +# Author: Ralph E. Griswold +# +# Date: April 30, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# create_array([lbs], [ubs], value) creates a n-dimensional array +# with the specified lower bounds, upper bounds, and with each array element +# having the specified initial value. +# +# ref_array(A, i1, i2, ...) references the i1-th i2-th ... element of A. +# +############################################################################ + +record array(structure, lbs) + +procedure create_array(lbs, ubs, value) + local lengths, i + + if (*lbs ~= *ubs) | (*lbs = 0) then stop("*** bad specification") + + lengths :=list(*lbs) + + every i := 1 to *lbs do + lengths[i] := ubs[i] - lbs[i] + 1 + + return array(create_struct(lengths, value), lbs) + +end + +procedure create_struct(lengths, value) + local A + + lengths := copy(lengths) + + A := list(get(lengths), value) + + if *lengths > 0 then + every !A := create_struct(lengths, value) + + return A + +end + +procedure ref_array(A, subscrs[]) + local lbs, i, A1 + + if *A.lbs ~= *subscrs then + stop("*** bad specification") + + lbs := A.lbs + A1 := A.structure + + every i := 1 to *subscrs - 1 do + A1 := A1[subscrs[i] - lbs[i] + 1] | fail + + return A1[subscrs[-1] - lbs[-1] + 1] + +end diff --git a/ipl/procs/asciinam.icn b/ipl/procs/asciinam.icn new file mode 100644 index 0000000..44cfe93 --- /dev/null +++ b/ipl/procs/asciinam.icn @@ -0,0 +1,33 @@ +############################################################################ +# +# File: asciinam.icn +# +# Subject: Procedure for ASCII name of unprintable character +# +# Author: Robert J. Alexander +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# asciiname(s) returns the mnemonic name of the single unprintable +# ASCII character s. +# +############################################################################ + +procedure asciiname(s) + local o + static names + initial { + names := ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL", + "BS" ,"HT" ,"NL" ,"VT" ,"NP" ,"CR" ,"SO" ,"SI" , + "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB", + "CAN","EM" ,"SUB","ESC","FS" ,"GS" ,"RS" ,"US" ] + } + o := ord(s) + return names[o + 1] | (if o = 127 then "DEL") +end diff --git a/ipl/procs/base64.icn b/ipl/procs/base64.icn new file mode 100644 index 0000000..2502be1 --- /dev/null +++ b/ipl/procs/base64.icn @@ -0,0 +1,77 @@ +############################################################################# +# +# File: base64.icn +# +# Subject: Procedures for base64 encodings for MIME (RFC 2045) +# +# Author: David A. Gamey +# +# Date: May 2, 2001 +# +############################################################################# +# +# This file is in the public domain. +# +############################################################################# +# +# Descriptions: +# +# base64encode( s1 ) : s2 +# +# returns the base64 encoding of a string s1 +# +# base64decode( s1 ) : s2 +# +# returns the base64 decoding of a string s1 +# fails if s1 isn't base64 encoded +# +# references: MIME encoding Internet RFC 2045 +# +############################################################################# + +procedure base64encode(s) #: encode a string into base 64 (MIME) + local pad, t, i, j, k + static b64 + initial b64 := &ucase || &lcase || &digits || "+/" + + i := (3 - (*s % 3)) % 3 + s ||:= repl("\x00",i) + pad := repl("=",i) + + t := "" + s ? while ( i := ord(move(1)), j := ord(move(1)), k := ord(move(1)) ) do { + t ||:= b64[ 1 + ishift(i,-2) ] + t ||:= b64[ 1 + ior( ishift(iand(i,3),4), ishift(j,-4) ) ] + t ||:= b64[ 1 + ior( ishift(iand(j,15),2), ishift(k,-6) ) ] + t ||:= b64[ 1 + iand(k,63) ] + } + t[ 0 -: *pad ] := pad + + return t +end + +procedure base64decode(s) #: decode a string from base 64 (MIME) + local t, w, x, y, z + static b64, c64, n64 + initial { + b64 := &ucase || &lcase || &digits || "+/" + c64 := cset(b64) + n64 := string(&cset)[1+:64] + } + + if not s ? ( tab(many(c64)), =("===" | "==" | "=" | ""), pos(0)) then fail + if ( *s % 4 ) ~= 0 then fail + + s := map(s,"=","\x00") + s := map(s,b64,n64) + + t := "" + s ? while ( w := ord(move(1)), x := ord(move(1)), + y := ord(move(1)), z := ord(move(1)) ) do { + t ||:= char( ior( ishift(w,2), ishift(x,-4) ) ) + t ||:= char( ior( iand(ishift(x,4),255), ishift(y,-2) ) ) + t ||:= char( ior( iand(ishift(y,6),255), z ) ) + } + + return trim(t,'\x00') +end diff --git a/ipl/procs/basename.icn b/ipl/procs/basename.icn new file mode 100644 index 0000000..8ad7b98 --- /dev/null +++ b/ipl/procs/basename.icn @@ -0,0 +1,41 @@ +############################################################################ +# +# File: basename.icn +# +# Subject: Procedures to produce base name of a file +# +# Author: Ralph E. Griswold +# +# Date: September 22, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Contributor: Charles Shartsis +# +############################################################################ +# +# This procedure is based on the UNIX basename(1) utility. It strips off +# any path information and removes the specified suffix, if present. +# +# If no suffix is provided, the portion of the name up to the first +# "." is returned. +# +# It should work under UNIX, MS-DOS, and the Macintosh. +# +############################################################################ + +procedure basename(name, suffix) #: base name of file + local i, base + + name ? { + every i := upto('/\\:') + tab(integer(i) + 1) # get rid of path, if any + if base := 1(tab(find(\suffix)), pos(-*suffix)) then return base + else return tab(0) + } + +end diff --git a/ipl/procs/binary.icn b/ipl/procs/binary.icn new file mode 100644 index 0000000..79a5c58 --- /dev/null +++ b/ipl/procs/binary.icn @@ -0,0 +1,970 @@ +############################################################################ +# +# File: binary.icn +# +# Subject: Procedures to pack and unpack values +# +# Author: Robert J. Alexander +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This is a collection of procedures that support conversion of Icon +# data elements to and from binary data formats. The purpose is to +# facilitate dealing with binary data files. +# +# The procedures can be used individually or via the "control" +# procedures pack() and unpack(). +# +############################################################################ +# +# The individual conversion functions are prefixed by either "pack_" or +# "unpack_" and are identified in comments by their format character(s). +# The "pack_" procedures convert from Icon to binary and take a single +# argument: the value to be converted. The "unpack_" procedures +# convert from binary to Icon and usually take no parameters -- they are +# executed within a string-scanning context and scan the necessary +# amount from the &subject string. Some of the "unpack_" functions take +# a parameter that specifies the length of the output string. The +# individual conversion procedures are minimally commented, but their +# action is apparent from their procedure names and the documentation +# of the pack() and unpack() procedures. +# +# The control procedures pack() and unpack() take a format string that +# controls conversions of several values (similar to the "printf" C +# library function). pack() and unpack() are patterned after the Perl +# (programming language) functions of the same names, and are documented +# below. +# +# +# pack(template,value1,...) : packed_binary_string +# ------------------------------------------------ +# +# This procedure packs the "values" into a binary structure, returning +# the string containing the structure. The elements of any lists in the +# "value" parameters are processed individually as if they were +# "spliced" into the "value" parameter list. The "template" is a +# sequence of characters that give the order and type of values, as +# follows" (using C language terminology): +# +# a An ascii string, will be null padded (unstripped for unpack()). +# A An ascii string, will be space padded (trailing nulls and +# spaces will be stripped for unpack()). +# b A bit string, low-to-high order. +# B A bit string, high-to-low order. +# h A hexadecimal string, low-nybble-first. +# H A hexadecimal string, high-nybble-first. +# c A signed char value. +# C An unsigned char value. +# s A signed short value. +# S An unsigned short value. +# i A signed int value. +# I An unsigned int value. +# l A signed long value. +# L An unsigned long value. +# n A short in "network" order (big-endian). +# N A long in "network" order (big-endian). +# v A short in "vax" order (little-endian). +# V A long in "vax" order (little-endian). +# f A single-precision float in IEEE Motorola format. +# d A double-precision float in IEEE Motorola format. +# e An extended-precision float in IEEE Motorola format 80-bit. +# E An extended-precision float in IEEE Motorola format 96-bit. +# x Skip forward a byte (null-fill for pack()). +# X Back up a byte. +# @ Go to absolute position (null-fill if necessary for pack()). +# u A uu-encoded/decoded string. +# +# Each letter may optionally be followed by a number which gives a +# count. Together the letter and the count make a field specifier. +# Letters and numbers can be separated by white space which will be +# ignored. Types A, a, B, b, H, and h consume one value from the +# "value" list and produce a string of the length given as the +# field-specifier-count. The other types consume +# "field-specifier-count" values from the "value" list and append the +# appropriate data to the packed string. +# +# +# unpack(template,string) : value_list +# ------------------------------------ +# +# This procedure does the reverse of pack(): it takes a string +# representing a structure and expands it out into a list of values. +# The template has mostly the same format as for pack() -- see pack(), +# above. +# +# +# Endianicity of integers +# ----------------------- +# +# Integer values can be packed and unpacked in either big-endian +# (Motorola) or little-endian (Intel) order. The default is big-endian. +# Procedures pack_little_endian() and pack_big_endian() set the +# mode for future packs and unpacks. +# +# +# Size of ints +# ------------ +# +# The "i" (signed int) and "I" (unsigned int) types can pack and unpack +# either 16-bit or 32-bit values. 32-bit is the default. Procedures +# pack_int_as_short() and pack_int_as_long() change the mode for +# future packs and unpacks. +# +############################################################################ + + +# +# To Do List +# +# - implement other-endian versions of floats (only big-endian supported +# now). +# + +# +# The implementation +# + +global pack_short,pack_long, + unpack_short,unpack_unsigned_short, + unpack_long,unpack_unsigned_long, + pack_int_proc,unpack_int_proc,unpack_unsigned_int_proc + + +procedure pack(template,values[]) #: pack values into a string + local result,t,n,c,v,spliced_values + initial if /pack_short then pack_big_endian() + spliced_values := [] + every v := !values do { + if type(v) == "list" then spliced_values |||:= v + else put(spliced_values,v) + } + values := spliced_values + result := "" + every t := pack_parse_template(template) do { + n := t.count + c := t.conversion + case c of { + !"aAbBhH": { + # + # Handle string. + # + v := string(get(values)) | break + if n == "*" then n := *v + result ||:= (case c of { + !"aA": if integer(n) then left(v,n,if c == "A" then " " + else "\0") else v + default: (case c of { + "b": pack_bits_low_to_high + "B": pack_bits_high_to_low + "h": pack_hex_low_to_high + "H": pack_hex_high_to_low + })(v[1:n + 1 | 0]) + }) | break + } + "@": result := left(result,n + 1,"\0") + "x": result := left(result,*result + n,"\0") + "X": result := left(result,*result - n) + default: { + # + # Handle item that consumes argument(s). + # + every if n === "*" then &null else 1 to n do { + v := get(values) | break + result ||:= (case c of { + !"cC": pack_char + !"sS": pack_short + !"iI": pack_int + !"lL": pack_long + "n": pack_nshort + "N": pack_nlong + "v": pack_vshort + "V": pack_vlong + "f": pack_single_float + "d": pack_double_float + "e": pack_extended_float + "E": pack_extended96_float + "u": pack_uuencoded_string + })(v) | break + } + } + } + } + return result +end + +procedure unpack(template,binaryString) #: unpack values from string + local result,t,n,c,v + initial if /unpack_short then pack_big_endian() + result := [] + binaryString ? { + every t := pack_parse_template(template) do { + n := t.count + c := t.conversion + case c of { + "X": move(-integer(n)) | tab(1) + "x": move(integer(n)) | tab(0) + "@": tab(if n === "*" then 0 else n) + !"aA": { + v := move(integer(n)) | tab(0) + if c == "A" then v := trim(v,' \t\0') + put(result,v) + } + !"bBhH": { + put(result,(case c of { + "b": unpack_bits_low_to_high + "B": unpack_bits_high_to_low + "h": unpack_hex_low_to_high + "H": unpack_hex_high_to_low + })(n)) + } + default: { + every if n === "*" then &null else 1 to n do { + if pos(0) then break + put(result,(case c of { + "c": unpack_char + "C": unpack_unsigned_char + "s": unpack_short + "S": unpack_unsigned_short + "i": unpack_int + "I": unpack_unsigned_int + "l": unpack_long + "L": unpack_unsigned_long + "n": unpack_nshort + "N": unpack_nlong + "v": unpack_vshort + "V": unpack_vlong + "f": unpack_single_float + "d": unpack_double_float + "e": unpack_extended_float + "E": unpack_extended96_float + "u": unpack_uuencoded_string + })()) | break + } + } + } + } + } + return result +end + +record pack_template_rec(conversion,count) + +procedure pack_parse_template(template) + local c,n + template ? { + pack_parse_space() + while c := tab(any('aAbBhHcCsSiIlLnNvVfdeExX@u')) do { + pack_parse_space() + n := ="*" | integer(tab(many(&digits))) | 1 + suspend pack_template_rec(c,n) + pack_parse_space() + } + } +end + +procedure pack_parse_space() + suspend tab(many(' \t')) +end + +procedure pack_big_endian() + pack_short := pack_nshort + pack_long := pack_nlong + unpack_short := unpack_nshort + unpack_unsigned_short := unpack_unsigned_nshort + unpack_long := unpack_nlong + unpack_unsigned_long := unpack_unsigned_nlong + case pack_int_proc of { + pack_vshort: pack_int_as_short() + pack_vlong: pack_int_as_long() + } + return +end + +procedure pack_little_endian() + pack_short := pack_vshort + pack_long := pack_vlong + unpack_short := unpack_vshort + unpack_unsigned_short := unpack_unsigned_vshort + unpack_long := unpack_vlong + unpack_unsigned_long := unpack_unsigned_vlong + case pack_int_proc of { + pack_nshort: pack_int_as_short() + pack_nlong: pack_int_as_long() + } + return +end + +procedure pack_int_as_long() + pack_int_proc := pack_long + unpack_int_proc := unpack_long + unpack_unsigned_int_proc := unpack_unsigned_long + return +end + +procedure pack_int_as_short() + pack_int_proc := pack_short + unpack_int_proc := unpack_short + unpack_unsigned_int_proc := unpack_unsigned_short + return +end + +# +# "b" +# +procedure pack_bits_low_to_high(v) + local result,n,b,buf + result := "" + n := buf := 0 + every b := !v do { + buf := ior(ishift(buf,-1),ishift(b % 2,7)) + n +:= 1 + if n = 8 then { + result ||:= char(buf) + n := buf := 0 + } + } + if n > 0 then { + result ||:= char(ishift(buf,-(8 - n))) + } + return result +end + +# +# "B" +# +procedure pack_bits_high_to_low(v) + local result,n,b,buf + result := "" + n := buf := 0 + every b := !v do { + buf := ior(ishift(buf,1),b % 2) + n +:= 1 + if n = 8 then { + result ||:= char(buf) + n := buf := 0 + } + } + if n > 0 then { + result ||:= char(ishift(buf,8 - n)) + } + return result +end + +# +# "h" +# +procedure pack_hex_low_to_high(v) + local result,pair + result := "" + v ? { + while pair := move(2) do { + result ||:= char(ior(pack_hex_digit(pair[1]), + ishift(pack_hex_digit(pair[2]),4))) + } + result ||:= char(pack_hex_digit(move(1))) + } + return result +end + +# +# "H" +# +procedure pack_hex_high_to_low(v) + local result,pair + result := "" + v ? { + while pair := move(2) do { + result ||:= char(ior(pack_hex_digit(pair[2]), + ishift(pack_hex_digit(pair[1]),4))) + } + result ||:= char(ishift(pack_hex_digit(move(1)),4)) + } + return result +end + +procedure pack_hex_digit(s) + return (case map(s) of { + "0": 2r0000 + "1": 2r0001 + "2": 2r0010 + "3": 2r0011 + "4": 2r0100 + "5": 2r0101 + "6": 2r0110 + "7": 2r0111 + "8": 2r1000 + "9": 2r1001 + "a": 2r1010 + "b": 2r1011 + "c": 2r1100 + "d": 2r1101 + "e": 2r1110 + "f": 2r1111 + }) | stop("bad hex digit: ",image(s)) +end + +# +# "c" and "C" +# +procedure pack_char(v) + if v < 0 then v +:= 256 + return char(v) +end + +# +# "s" and "S" (big-endian) +# +procedure pack_nshort(v) + if v < 0 then v +:= 65536 + return char(v / 256) || char(v % 256) +end + +# +# "s" and "S" (little-endian) +# +procedure pack_vshort(v) + if v < 0 then v +:= 65536 + return char(v % 256) || char(v / 256) +end + +# +# "i" and "I" +# +procedure pack_int(v) + initial /pack_int_proc := pack_long + return pack_int_proc(v) +end + +# +# "l" and "L" (big-endian) +# +procedure pack_nlong(v) + local result + if v < 0 then v +:= 4294967296 + result := "" + every 1 to 4 do { + result ||:= char(v % 256) + v /:= 256 + } + return reverse(result) +end + +# +# "l" and "L" (little-endian) +# +procedure pack_vlong(v) + local result + if v < 0 then v +:= 4294967296 + result := "" + every 1 to 4 do { + result ||:= char(v % 256) + v /:= 256 + } + return result +end + +# +# "u" +# +procedure pack_uuencoded_string(v) + return UUEncodeString(v) +end + +# +# "b" +# +procedure unpack_bits_low_to_high(n) + local result,c,r + result := "" + while *result < n do { + c := ord(move(1)) | fail + r := "" + every 1 to 8 do { + r ||:= iand(c,1) + c := ishift(c,-1) + } + result ||:= r + } + return result[1+:n] | result +end + +# +# "B" +# +procedure unpack_bits_high_to_low(n) + local result,c,r + result := "" + while *result < n do { + c := ord(move(1)) | fail + r := "" + every 1 to 8 do { + r := iand(c,1) || r + c := ishift(c,-1) + } + result ||:= r + } + return result[1+:n] | result +end + +# +# "h" +# +procedure unpack_hex_low_to_high(n) + local result,c + result := "" + while *result < n do { + c := ord(move(1)) | fail + result ||:= unpack_hex_digit(iand(c,16rf)) || + unpack_hex_digit(ishift(c,-4)) + } + return result[1+:n] | result +end + +# +# "H" +# +procedure unpack_hex_high_to_low(n) + local result,c + result := "" + while *result < n do { + c := ord(move(1)) | fail + result ||:= unpack_hex_digit(ishift(c,-4)) || + unpack_hex_digit(iand(c,16rf)) + } + return result[1+:n] | result +end + +procedure unpack_hex_digit(i) + return "0123456789abcdef"[i + 1] +end + +# +# "c" +# +procedure unpack_char() + local v + v := ord(move(1)) | fail + if v >= 128 then v -:= 256 + return v +end + +# +# "C" +# +procedure unpack_unsigned_char() + return ord(move(1)) +end + +# +# "n" and "s" (big-endian) +# +procedure unpack_nshort() + local v + v := unpack_unsigned_nshort() | fail + if v >= 32768 then v -:= 65536 + return v +end + +# +# "v" and "s" (little-endian) +# +procedure unpack_vshort() + local v + v := unpack_unsigned_vshort() | fail + if v >= 32768 then v -:= 65536 + return v +end + +# +# "S" (big-endian) +# +procedure unpack_unsigned_nshort() + return 256 * ord(move(1)) + ord(move(1)) +end + +# +# "S" (little-endian) +# +procedure unpack_unsigned_vshort() + return ord(move(1)) + 256 * ord(move(1)) +end + +# +# "i" +# +procedure unpack_int() + initial /unpack_int_proc := unpack_long + return unpack_int_proc() +end + +# +# "I" (aye) +# +procedure unpack_unsigned_int() + initial /unpack_unsigned_int_proc := unpack_unsigned_long + return unpack_unsigned_int_proc() +end + +# +# "N" and "l" (ell) (big-endian) +# +procedure unpack_nlong() + local v + v := 0 + every 1 to 4 do { + v := 256 * v + ord(move(1)) | fail + } + if v >= 2147483648 then v -:= 4294967296 + return v +end + +# +# "V" and "l" (ell) (little-endian) +# +procedure unpack_vlong() + local v,m + v := 0 + m := 1 + every 1 to 4 do { + v := v + m * ord(move(1)) | fail + m *:= 256 + } + if v >= 2147483648 then v -:= 4294967296 + return v +end + +# +# "L" (big-endian) +# +procedure unpack_unsigned_nlong() + local v + v := 0 + every 1 to 4 do { + v := v * 256 + ord(move(1)) | fail + } + return v +end + +# +# "L" (little-endian) +# +procedure unpack_unsigned_vlong() + local v,m + v := 0 + m := 1 + every 1 to 4 do { + v := v + m * ord(move(1)) | fail + m *:= 256 + } + return v +end + +# +# "u" +# +procedure unpack_uuencoded_string() + return UUDecodeString(tab(0)) +end + +# +# Procedures for converting real values from input streams. These +# procedures accept standard IEEE floating point values as strings, +# usually as read from a file, and return their numeric equivalent as a +# "real". The degree of accuracy is likely to vary with different +# implementations of Icon. +# +# Requires large integers. +# +# Parameter Float Double Extended Extended96 +# ================================================================= +# Size (bytes:bits) 4:32 8:64 10:80 12:96 +# +# Range of binary exponents +# Minimum -126 -1022 -16383 -16383 +# Maximum +127 +1023 +16383 +16383 +# Exponent width in bits 8 11 15 15 +# Exponent bias +127 +1023 +16383 +16383 +# +# Significand precision +# Bits 24 53 64 64 +# Decimal digits 7-8 15-16 18-19 18-19 +# +# Decimal range approximate +# Maximum positive 3.4E+38 1.7E+308 1.1E+4932 +# Minimum positive norm 1.2E-38 2.3E-308 1.7E-4932 +# Minimum positive denorm 1.5E-45 5.0E-324 1.9E-4951 +# Maximum negative denorm -1.5E-45 -5.0E-324 -1.9E-4951 +# Maximum negative norm -1.2E-38 -2.3E-308 -1.7E-4932 +# Minimum negative -3.4E+38 -1.7E+308 -1.1E+4932 +# + +# +# "d" +# +procedure pack_double_float(v) + local exp,mant,result,av + static dvsr + initial dvsr := 2.0 ^ 52 + v := real(v) + if v = 0.0 then return "\0\0\0\0\0\0\0\0" + else { + av := abs(v) + exp := integer(log(av,2)) + if exp <= -1023 then return "\0\0\0\0\0\0\0\0" + if exp > 1023 then return if v < 0.0 then "\xff\xf0\0\0\0\0\0\0" + else "\x7f\xf0\0\0\0\0\0\0" + mant := integer(av / 2.0 ^ real(exp) * dvsr + 0.5) + exp +:= 1023 + result := "" + every 3 to 8 do { + result := char(mant % 256) || result + mant /:= 256 + } + result := char(ior(if v < 0.0 then 16r80 else 0,ishift(exp,-4))) || + char(ior(iand(mant % 256,16rf),iand(ishift(exp,4),16rf0))) || + result + return result + } +end + +# +# "f" +# +procedure pack_single_float(v) + local exp,mant,result,av + static dvsr + initial dvsr := 2.0 ^ 23 + v := real(v) + if v = 0.0 then return "\0\0\0\0" + else { + av := abs(v) + exp := integer(log(av,2)) + if exp <= -127 then return "\0\0\0\0" + if exp > 127 then return if v < 0.0 then "\xff\x80\0\0" + else "\x7f\x80\0\0" + mant := integer(av / 2.0 ^ real(exp) * dvsr + 0.5) + exp +:= 127 + result := "" + every 3 to 4 do { + result := char(mant % 256) || result + mant /:= 256 + } + result := char(ior(if v < 0.0 then 16r80 else 0,ishift(exp,-1))) || + char(ior(iand(mant % 256,16r7f),iand(ishift(exp,7),16r80))) || + result + return result + } +end + +# +# "e" +# +procedure pack_extended_float(v) + local exp,mant,result,av + static dvsr + initial dvsr := 2.0 ^ 63 + v := real(v) + if v = 0.0 then return "\0\0\0\0\0\0\0\0\0\0" + else { + av := abs(v) + exp := integer(log(av,2)) + if exp <= -16383 then return "\0\0\0\0\0\0\0\0\0\0" + if exp > 16383 then return if v < 0.0 then "\xff\xff\0\0\0\0\0\0\0\0" + else "\x7f\xff\0\0\0\0\0\0\0\0" + mant := integer(av / 2.0 ^ real(exp) * dvsr + 0.5) + exp +:= 16383 + result := "" + every 3 to 10 do { + result := char(mant % 256) || result + mant /:= 256 + } + result := char(ior(if v < 0.0 then 16r80 else 0,ishift(exp,-8))) || + char(iand(exp,16rff)) || + result + return result + } +end + +# +# "E" +# +procedure pack_extended96_float(v) + return pack_x80tox96(pack_extended_float(v)) +end + +# +# "d" +# +procedure unpack_double_float() + local exp,mant,v,i,s + static dvsr + initial dvsr := 2.0 ^ 52 + (s := move(8)) | fail + exp := ior(ishift(iand(ord(s[1]),16r7f),4),ishift(ord(s[2]),-4)) - 1023 + v := if exp = -1023 then 0.0 + else { + mant := ior(16r10,iand(ord(s[2]),16r0f)) + every i := 3 to 8 do + mant := mant * 256 + ord(s[i]) + mant / dvsr * 2.0 ^ real(exp) + } + return if s[1] >>= "\x80" then -v else v +end + +# +# "f" +# +procedure unpack_single_float() + local exp,mant,v,i,s + static dvsr + initial dvsr := 2.0 ^ 23 + (s := move(4)) | fail + exp := ior(ishift(iand(ord(s[1]),16r7f),1),ishift(ord(s[2]),-7)) - 127 + v := if exp = -127 then 0.0 + else { + mant := ior(16r80,iand(ord(s[2]),16r7f)) + every i := 3 to 4 do + mant := mant * 256 + ord(s[i]) + mant / dvsr * 2.0 ^ real(exp) + } + return if s[1] >>= "\x80" then -v else v +end + +# +# "e" +# +procedure unpack_extended_float(s) + local exp,mant,v,i + static dvsr + initial dvsr := 2.0 ^ 63 + if /s then + (s := move(10)) | fail + exp := ior(ishift(iand(ord(s[1]),16r7f),8),ord(s[2])) - 16383 + v := if exp = -16383 then 0.0 + else { + mant := ord(s[3]) + every i := 4 to 10 do + mant := mant * 256 + ord(s[i]) + mant / dvsr * 2.0 ^ real(exp) + } + return if s[1] >>= "\x80" then -v else v +end + +# +# "E" +# +procedure unpack_extended96_float() + return unpack_extended_float(pack_x96tox80(move(12))) +end + + +procedure pack_x80tox96(s) + return s[1:3] || "\0\0" || s[3:0] +end + + +procedure pack_x96tox80(s) + return s[1:3] || s[5:0] +end + + +# +# Procedures for working with UNIX "uuencode" format. +# + +global UUErrorText + +# +# Decode a uu-encoded string. +# +procedure UUDecodeString(s) + local len + s ? { + len := UUDecodeChar(move(1)) + s := "" + while s ||:= UUDecodeQuad(move(4)) + if not pos(0) then { + UUErrorText := "not multiple of 4 encoded characters" + fail + } + if not (0 <= *s - len < 3) then { + UUErrorText := "actual length, " || *s || + " doesn't jive with length character, " || len + fail + } + } + return s[1+:len] | s +end + +# +# Get a binary value from a uu-encoded character. +# +procedure UUDecodeChar(s) + static spaceVal + initial spaceVal := ord(" ") + return ord(s) - spaceVal +end + +# +# Decode 4-byte encoded string to 3-bytes of binary data. +# +procedure UUDecodeQuad(s) + local v1,v2,v3,v4 + *s = 4 | { + write(&errout,"Input string not of length 4") + runerr(500,s) + } + v1 := UUDecodeChar(s[1]) + v2 := UUDecodeChar(s[2]) + v3 := UUDecodeChar(s[3]) + v4 := UUDecodeChar(s[4]) + return ( + char(ior(ishift(v1,2),ishift(v2,-4))) || + char(ior(ishift(iand(v2,16rf),4),ishift(v3,-2))) || + char(ior(ishift(iand(v3,16r3),6),v4)) + ) +end + +# +# Convert "s" to uu-encoded format. +# +procedure UUEncodeString(s) + local outLine + s ? { + outLine := "" + until pos(0) do + outLine ||:= UUEncodeTriple(move(3) | tab(0)) + } + return UUEncodeChar(*s) || outLine +end + +# +# Get the ascii character for uu-encoding "i". +# +procedure UUEncodeChar(i) + static spaceVal + initial spaceVal := ord(" ") + return char(i + spaceVal) +end + +# +# Encode to 3-bytes of binary data into 4-byte uu-encoded string. +# +procedure UUEncodeTriple(s) + local v1,v2,v3 + v1 := ord(s[1]) + v2 := ord(s[2]) | 0 + v3 := ord(s[3]) | 0 + return ( + UUEncodeChar(ishift(v1,-2)) || + UUEncodeChar(ior(ishift(iand(v1,16r3),4),ishift(v2,-4))) || + UUEncodeChar(ior(ishift(iand(v2,16rf),2),ishift(v3,-6))) || + UUEncodeChar(iand(v3,16r3f)) + ) +end diff --git a/ipl/procs/bincvt.icn b/ipl/procs/bincvt.icn new file mode 100644 index 0000000..6a54835 --- /dev/null +++ b/ipl/procs/bincvt.icn @@ -0,0 +1,62 @@ +############################################################################ +# +# File: bincvt.icn +# +# Subject: Procedures to convert binary data +# +# Author: Robert J. Alexander +# +# Date: October 16, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# unsigned() -- Converts binary byte string into unsigned integer. +# Detects overflow if number is too large. +# +# This procedure is normally used for processing of binary data +# read from a file. +# +# raw() -- Puts raw bits of characters of string s into an integer. If +# the size of s is less than the size of an integer, the bytes are put +# into the low order part of the integer, with the remaining high order +# bytes filled with zero. If the string is too large, the most +# significant bytes will be lost -- no overflow detection. +# +# This procedure is normally used for processing of binary data +# read from a file. +# +# rawstring() -- Creates a string consisting of the raw bits in the low +# order "size" bytes of integer i. +# +# This procedure is normally used for processing of binary data +# to be written to a file. +# +############################################################################ + +procedure unsigned(s) + local i + i := 0 + every i := ord(!s) + i * 256 + return i +end + +procedure raw(s) + local i + i := 0 + every i := ior(ord(!s),ishift(i,8)) + return i +end + +procedure rawstring(i,size) + local s + s := "" + every 1 to size do { + s := char(iand(i,16rFF)) || s + i := ishift(i,-8) + } + return s +end diff --git a/ipl/procs/binop.icn b/ipl/procs/binop.icn new file mode 100644 index 0000000..0647245 --- /dev/null +++ b/ipl/procs/binop.icn @@ -0,0 +1,32 @@ +############################################################################ +# +# File: binop.icn +# +# Subject: Procedure to apply binary operation to list of values +# +# Author: Ralph E. Griswold +# +# Date: July 15, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure applies a binary operation to a list of arguments. +# For example, +# +# binop("+", 1, 2, 3) +# +# returns 6. +# +############################################################################ + +procedure binop(op, result, rest[]) #: apply binary operation + + every result := op(result, !rest) + + return result + +end diff --git a/ipl/procs/bitint.icn b/ipl/procs/bitint.icn new file mode 100644 index 0000000..51e73f7 --- /dev/null +++ b/ipl/procs/bitint.icn @@ -0,0 +1,43 @@ +############################################################################ +# +# File: bitint.icn +# +# Subject: Procedures to convert integers and bit strings +# +# Author: Ralph E. Griswold +# +# Date: May 25, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# int2bit(i) produces a string with the bit representation of i. +# +# bit2int(s) produces an integer corresponding to the bit representation i. +# +############################################################################ + +procedure int2bit(i) + local s, sign + + if i = 0 then return 0 + if i < 0 then { + sign := "-" + i := -i + } + else sign := "" + s := "" + while i > 0 do { + s := (i % 2) || s + i /:= 2 + } + return sign || s +end + +procedure bit2int(s) + if s[1] == "-" then return "-" || integer("2r" || s[2:0]) + else return integer("2r" || s) +end diff --git a/ipl/procs/bitstr.icn b/ipl/procs/bitstr.icn new file mode 100644 index 0000000..6942480 --- /dev/null +++ b/ipl/procs/bitstr.icn @@ -0,0 +1,148 @@ +############################################################################ +# +# File: bitstr.icn +# +# Subject: Procedures for bits in Icon strings +# +# Author: Robert J. Alexander +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Procedures for working with strings made up of numeric values +# represented by strings of an arbitrary number of bits, stored without +# regard to character boundaries. +# +# In conjunction with the "large integers" feature of Icon, this +# facility can deal with bitstring segments of arbitrary size. If +# "large integers" are not supported, bitstring segments (i.e. the +# nbits parameter of BitStringGet and BitStringPut) wider that the +# integer size of the platform are likely to produce incorrect results. +# +############################################################################ +# +# Usage of BitStringPut, by example: +# +# record bit_value(value, nbits) +# ... +# bitString := BitString("") +# while value := get_new_value() do # loop to append to string +# BitStringPut(bitString, value.nbits, value.value) +# resultString := BitStringPut(bitString) # output any buffered bits +# +# Note the interesting effect that BitStringPut(bitString), as well as +# producing the complete string, pads the buffered string to an even +# character boundary. This can be dune during construction of a bit +# string if the effect is desired. +# +# The "value" argument defaults to zero. +# +############################################################################ +# +# Usage of BitStringGet, by example: +# +# record bit_value(value, nbits) +# ... +# bitString := BitString(string_of_bits) +# while value := BitStringGet(bitString, nbits) do +# # do something with value +# +# BitStringGet fails when too few bits remain to satisfy a request. +# However, if bits remain in the string, subsequent calls with fewer +# bits requested may succeed. A negative "nbits" value gets the value +# of the entire remainder of the string, to the byte boundary at its +# end. +# +############################################################################ +# +# See also: bitstrm.icn +# +############################################################################ + +record BitString(s, buffer, bufferBits) + +procedure BitStringPut(bitString, nbits, value) + local outvalue + # + # Initialize. + # + /bitString.buffer := bitString.bufferBits := 0 + # + # If this is "close" call ("nbits" is null), flush buffer, + # reinitialize, and return the bit string with the final character + # value zero padded on the right. + # + if /nbits then { + if bitString.bufferBits > 0 then + bitString.s ||:= + char(ishift(bitString.buffer, 8 - bitString.bufferBits)) + bitString.buffer := bitString.bufferBits := 0 + return bitString.s + } + # + # Merge new value into buffer. + # + /value := 0 + bitString.buffer := ior(ishift(bitString.buffer, nbits), value) + bitString.bufferBits +:= nbits + # + # Output bits. + # + while bitString.bufferBits >= 8 do { + bitString.s ||:= char(outvalue := + ishift(bitString.buffer, 8 - bitString.bufferBits)) + bitString.buffer := + ixor(bitString.buffer, ishift(outvalue, bitString.bufferBits - 8)) + bitString.bufferBits -:= 8 + } + return +end + + +procedure BitStringGet(bitString, nbits) + local value, save, i + # + # Initialize. + # + /bitString.buffer := bitString.bufferBits := 0 + # + # Get more data if necessary. + # + save := copy(bitString) + while nbits < 0 | bitString.bufferBits < nbits do { + (bitString.buffer := + ior(ishift(bitString.buffer, 8), ord(bitString.s[1]))) | { + # + # There aren't enough bits left in the file. Restore the + # BitString to its state before the call (in case he wants to + # try again), and fail. + # + if nbits >= 0 then { + every i := 1 to *bitString do + bitString[i] := save[i] + fail + } + else { + bitString.s := "" + bitString.bufferBits := value := 0 + value :=: bitString.buffer + return value + } + } + bitString.s[1] := "" + bitString.bufferBits +:= 8 + } + # + # Extract value from buffer and return. + # + value := ishift(bitString.buffer, nbits - bitString.bufferBits) + bitString.buffer := + ixor(bitString.buffer, ishift(value, bitString.bufferBits - nbits)) + bitString.bufferBits -:= nbits + return value +end diff --git a/ipl/procs/bitstrm.icn b/ipl/procs/bitstrm.icn new file mode 100644 index 0000000..44b46f5 --- /dev/null +++ b/ipl/procs/bitstrm.icn @@ -0,0 +1,123 @@ +############################################################################ +# +# File: bitstrm.icn +# +# Subject: Procedures to read and write strings of bits in files +# +# Author: Robert J. Alexander +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Procedures for reading and writing integer values made up of an +# arbitrary number of bits, stored without regard to character +# boundaries. +# +############################################################################ +# +# Usage of BitStreamWrite, by example: +# +# record bit_value(value, nbits) +# ... +# BitStreamWrite() #initialize +# while value := get_new_value() do # loop to output values +# BitStreamWrite(outfile, value.nbits, value.value) +# BitStreamWrite(outfile) # output any buffered bits +# +# Note the interesting effect that BitStreamWrite(outproc), as well as +# outputting the complete string, pads the output to an even character +# boundary. This can be dune during construction of a bit string if +# the effect is desired. +# +# The "value" argument defaults to zero. +# +############################################################################ +# +# Usage of BitStreamRead, by example: +# +# BitStreamRead() +# while value := BitStreamRead(infile, nbits) do +# # do something with value +# +# BitStringRead fails when too few bits remain to satisfy a request. +# +############################################################################ +# +# See also: bitstr.icn +# +############################################################################ + +procedure BitStreamWrite(outfile,bits,value,outproc) + local outvalue + static buffer,bufferbits + # + # Initialize. + # + initial { + buffer := bufferbits := 0 + } + /outproc := writes + # + # If this is "close" call, flush buffer and reinitialize. + # + if /value then { + outvalue := &null + if bufferbits > 0 then + outproc(outfile,char(outvalue := ishift(buffer,8 - bufferbits))) + buffer := bufferbits := 0 + return outvalue + } + # + # Merge new value into buffer. + # + buffer := ior(ishift(buffer,bits),value) + bufferbits +:= bits + # + # Output bits. + # + while bufferbits >= 8 do { + outproc(outfile,char(outvalue := ishift(buffer,8 - bufferbits))) + buffer := ixor(buffer,ishift(outvalue,bufferbits - 8)) + bufferbits -:= 8 + } + return outvalue +end + + +procedure BitStreamRead(infile,bits,inproc) + local value + static buffer,bufferbits + # + # Initialize. + # + initial { + buffer := bufferbits := 0 + } + # + # Reinitialize if called with no arguments. + # + if /infile then { + buffer := bufferbits := 0 + return + } + # + # Read in more data if necessary. + # + /inproc := reads + while bufferbits < bits do { + buffer := ior(ishift(buffer,8),ord(inproc(infile))) | fail + bufferbits +:= 8 + } + # + # Extract value from buffer and return. + # + value := ishift(buffer,bits - bufferbits) + buffer := ixor(buffer,ishift(value,bufferbits - bits)) + bufferbits -:= bits + return value +end diff --git a/ipl/procs/bkutil.icn b/ipl/procs/bkutil.icn new file mode 100644 index 0000000..97d9bac --- /dev/null +++ b/ipl/procs/bkutil.icn @@ -0,0 +1,81 @@ +############################################################################ +# +# File: bkutil.icn +# +# Subject: Procedures for HP95LX phone books and appointment books +# +# Author: Robert J. Alexander +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Utility procedures for HP95LX phone book and appointment book processing. +# +############################################################################ +# +# See also: abkform.icn, pbkform.icn +# +############################################################################ + +procedure bk_int(i) + return char(i % 256) || char(i / 256) +end + +procedure bk_read_int(f) + return ord(reads(f)) + 256 * ord(reads(f)) +end + +procedure bk_format_lines(s,width) + local lines,lines2,line,c,lineSeg + /width := 39 + lines := [] + # + # Make a list of the actual lines, as delimited by "\0". + # + s ? { + while put(lines,tab(find("\0"))) do move(1) + put(lines,"" ~== tab(0)) + } + # + # Now build a new list, with lines longer than "width" broken at + # word boundaries. + # + lines2 := [] + every line := !lines do { + while *line > width do { + line ? { + # + # Scan back from end of string to find a space + # + tab(width + 2) + until pos(1) do { + c := move(-1) + if c == " " then break + } + if pos(1) then { + # + # No space was found -- use next "width" chars. + # + lineSeg := move(width) + line := tab(0) + } + else { + # + # A space was found -- break line there. + # + lineSeg := &subject[1:&pos] + move(1) + line := tab(0) + } + put(lines2,lineSeg) + } + } + put(lines2,line) + } + return lines2 +end diff --git a/ipl/procs/bold.icn b/ipl/procs/bold.icn new file mode 100644 index 0000000..5764f4d --- /dev/null +++ b/ipl/procs/bold.icn @@ -0,0 +1,58 @@ +############################################################################ +# +# File: bold.icn +# +# Subject: Procedures to embolden and underscore text +# +# Author: Ralph E. Griswold +# +# Date: March 25, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures produce text with interspersed characters suit- +# able for printing to produce the effect of boldface (by over- +# striking) and underscoring (using backspaces). +# +# bold(s) bold version of s +# +# uscore(s) underscored version of s +# +############################################################################ + +procedure bold(s) + local c + static labels, trans, max + initial { + labels := "1" + trans := repl("1\b",4) || "1" + max := *labels + trans := bold(string(&lcase)) + labels := string(&lcase) + max := *labels + } + if *s <= max then + return map(left(trans,9 * *s),left(labels,*s),s) + else return bold(left(s,*s - max)) || + map(trans,labels,right(s,max)) +end + +procedure uscore(s) + static labels, trans, max + initial { + labels := "1" + trans := "_\b1" + max := *labels + trans := uscore(string(&lcase)) + labels := string(&lcase) + max := *labels + } + if *s <= max then + return map(left(trans,3 * *s),left(labels,*s),s) + else return uscore(left(s,*s - max)) || + map(trans,labels,right(s,max)) +end diff --git a/ipl/procs/boolops.icn b/ipl/procs/boolops.icn new file mode 100644 index 0000000..d7fd3b8 --- /dev/null +++ b/ipl/procs/boolops.icn @@ -0,0 +1,185 @@ +############################################################################ +# +# File: boolops.icn +# +# Subject: Procedure to perform Boolean operations on row patterns +# +# Author: Ralph E. Griswold +# +# Date: June 26, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Limitation: Assumes square patterns. +# +############################################################################ +# +# Links: convert +# +############################################################################ + +link convert + +procedure b0000(n, m) + local blank + + blank := [] + + every 1 to n do + put(blank, repl("0", m)) + + return blank + +end + +procedure b0001(rows1, rows2) + + return b01(b1110(rows1, rows2)) + +end + +procedure b0010(rows1, rows2) + + return b01(b1101(rows1, rows2)) + +end + +procedure b0011(rows1, rows2) + + return b01(b1100(rows1, rows2)) + +end + +procedure b01(rows) #: complement pattern + local new_rows, i + + new_rows := copy(rows) + + every i := 1 to *rows do + new_rows[i] := map(rows[i], "01", "10") + + return new_rows + +end + +procedure b0100(rows1, rows2) + + return b01(b1011(rows1, rows2)) + +end + +procedure b0101(rows1, rows2) + + return b01(b1010(rows1, rows2)) + +end + +procedure b0110(rows1, rows2) #: "xor" of two patterns + local pixels1, pixels2 + + pixels1 := inbase10(rows2pixels(rows1), 2) + pixels2 := inbase10(rows2pixels(rows2), 2) + + return pixels2rows(right(exbase10(ixor(pixels1, pixels2), 2), + *rows1 ^ 2, "0"), *rows1) + +end + +procedure b0111(rows1, rows2) + + return b01(b1000(rows1, rows2)) + +end + +procedure b1000(rows1, rows2) #: "and" of two patterns + local pixels1, pixels2 + + pixels1 := inbase10(rows2pixels(rows1), 2) + pixels2 := inbase10(rows2pixels(rows2), 2) + + return pixels2rows(right(exbase10(iand(pixels1, pixels2), 2), + *rows1 ^ 2, "0"), *rows1) + +end + +procedure b1001(rows1, rows2) + + return b01(b0110(rows1, rows2)) + +end + +procedure b1010(rows1, rows2) + + return copy(rows2) + +end + +procedure b1011(rows1, rows2) + + return b1110(b01(rows1), rows2) + +end + +procedure b1100(rows1, rows2) + + return copy(rows1) + +end + +procedure b1101(rows1, rows2) + + return b1110(rows1, b01(rows2)) + +end + +procedure b1110(rows1, rows2) #: "or" of two patterns + local pixels1, pixels2 + + pixels1 := inbase10(rows2pixels(rows1), 2) + pixels2 := inbase10(rows2pixels(rows2), 2) + + return pixels2rows(right(exbase10(ior(pixels1, pixels2), 2), + *rows1 ^ 2, "0"), *rows1) + +end + +procedure b1111(n, m) + static all + + initial { + all := [] + every 1 to n do + put(all, repl("1", m)) + } + + return all + +end + +procedure pixels2rows(pixels, n) + local rows + + rows := [] + + pixels ? { + while put(rows, move(n)) + } + + return rows + +end + +procedure rows2pixels(rows) + local pixels + + pixels := "" + + every pixels ||:= !rows + + return pixels + +end diff --git a/ipl/procs/bufread.icn b/ipl/procs/bufread.icn new file mode 100644 index 0000000..6310289 --- /dev/null +++ b/ipl/procs/bufread.icn @@ -0,0 +1,235 @@ +############################################################################ +# +# File: bufread.icn +# +# Subject: Procedures for buffered read and lookahead +# +# Author: Charles A. Shartsis +# +# Date: March 11,1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.0 +# +############################################################################ +# +# Synopsis: +# +# bufopen(s) Open a file name s for buffered read and lookahead +# bufread(f) Read the next line from file f +# bufnext(f, n) Return the next nth record from file f +# without changing the next record to be read by +# bufread +# bufclose(f) Close file f +# +############################################################################ +# +# These procedures provide a mechanism for looking ahead an +# arbitrary number of records in an open file while still +# keeping track of the logical current record and end-of-file. +# Although similar in intent to the procedures in buffer.icn, these +# procedures are used differently. The procedures bufopen, +# bufread, and bufclose were designed to closely mirror the +# built-in open, read, and close. +# +# A code segment like +# +# file := open("name", "r") | stop("open failed") +# while line := read(file) do { +# ...process current line... +# } +# close(file) +# +# can be changed to the following with no difference in behavior: +# +# file := bufopen("name", "r") | stop("open failed") +# while line := bufread(file) do { +# ...process current line... +# } +# bufclose(file) +# +# However in addition to processing the current line, one may +# also process subsequent lines BEFORE they are logically +# read: +# +# file := bufopen("name", "r") | stop("open failed") +# while line := bufread(file) do { +# ...process current line... +# line := bufnext(file,1) # return next line +# ...process next line... +# line := bufnext(file,2) # return 2nd next line +# ...process 2nd next line... +# ...etc... +# } +# bufclose(file) +# +# In the code above, calls to bufnext do not affect the results of +# subsequent bufread's. The bufread procedure always steps through +# the input file a line at a time without skipping lines whether or +# not bufnext is called. +# +############################################################################ +# +# Here is a more detailed description of the procedures: +# +# bufopen(s) +# ========== +# Produces a file resulting from opening s for reading ("r" option), +# but fails if the file cannot be opened. if s is missing or +# the value of s is &null, then standard input is opened and +# &input is returned. Unlike the Icon open function, bufopen() +# can and must be called prior to any call to bufread or bufnext +# involving standard input. Unlike named files, only one buffered +# standard input may be open at any given time. +# +# Default: +# s &null (indicates &input should be opened for buffered +# reading) +# +# Errors (from open): +# 103 s not string +# +# Errors (new): +# Attempt to open standard input when currently open +# +# +# bufread(f) +# ========== +# Produces a string consisting of the next line from f, but fails on +# end of file. Calls to bufnext do not affect the results of +# subsequent bufread's. The procedure bufread always steps +# through a file a line at a time without skipping lines. The +# procedure bufread fails when a logical end of file is +# reached, i.e., when the physical end of file has +# been reached AND the internal buffer is empty. +# +# Default: +# f &input +# +# Errors: +# f is not a file +# f not opened for buffered reads (includes &input) +# +# +# bufnext(f, n) +# ============= +# Produces a string consisting of the nth next line from f after +# the current line. It fails when the physical end of file +# has been reached. +# +# Default: +# f &input +# n 1 (the next line after the current one) +# +# Errors: +# f is not a file +# f not opened for buffered reads (includes &input) +# n not convertible to integer +# n not positive +# +# +# bufclose(f) +# =========== +# Produces f after closing it. Standard input must +# be closed before it can be reopened using bufopen. +# If standard input is closed, all lines read using bufnext +# are lost when it is reopened. In general, there is no +# practical reason to bufclose and then bufopen standard input. +# One may want to bufclose standard input to release its +# internal buffer for garbage collection. +# +# Default: +# f &input +# +# Errors (from close): +# 105 f not file +# +############################################################################ + +global __buf + +procedure bufopen(fname) + + local file + + if /__buf then + __buf := table(&null) + + if /fname then { + /__buf[&input] | stop("bufopen: Standard input is already open") + __buf[&input] := [] + return &input + } + else + if file := open(fname, "r") then { + __buf[file] := [] + return file + } + else fail + +end + +procedure bufclose(file) + + if /__buf then + __buf := table(&null) + + if /file then { + __buf[&input] := &null + return &input + } + else { + close(file) + __buf[file] := &null + return file + } + +end + +procedure bufread(file) + + local buf + + if /__buf then + __buf := table(&null) + + if /file then + file := &input + + type(file) == "file" | stop("bufread: Parameter is not a file") + buf := \__buf[file] | stop("bufread: File not open for buffered reads") + return get(buf) | read(file) + +end + +procedure bufnext(file, n) + + local buf + + if /__buf then + __buf := table(&null) + + if /file then + file := &input + + if /n then + n := 1 + + type(file) == "file" | stop("bufnext: Parameter is not a file") + integer(n) | stop("bufnext: Look ahead count was not convertible to integer") + (n > 0) | stop("bufnext: Look ahead count was non-positive") + buf := \__buf[file] | stop("bufnext: File not open for buffered reads") + + return buf[n] | + ( + while *buf < n do + (put(buf, read(file)) | break &fail) + ) | + buf[n] + +end diff --git a/ipl/procs/calendar.icn b/ipl/procs/calendar.icn new file mode 100644 index 0000000..ad65239 --- /dev/null +++ b/ipl/procs/calendar.icn @@ -0,0 +1,998 @@ +############################################################################ +# +# File: calendar.icn +# +# Subject: Procedures for data and time calculation and conversion +# +# Author: Robert J. Alexander +# +# Date: March 25, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Procedures in this file supersede several procedures in datetime.icn. +# +############################################################################ +# +# Setting up +# ---------- +# You will probably want to set a platform environment variable +# "Cal_TimeZone" to an appropriate local time zone ID string +# before using this library. Look at the time zone data at the +# end of this source file and choose an ID for your locale. +# Common ones for USA are "PST", "MST", "CST", and "EST", although +# there are more specific ones such as "America/Arizona" that +# handle special rules. If environment variables are not supported +# for your platform or your implementation of Icon, explicitly specify +# the default time zone in your program: e.g. +# +# Cal_CurrentTimeZone := Cal_GetTimeZone("PST"). +# +# If your system uses a base year for date calculation that is +# different from 1970, your can specify it in an environment +# variable "Cal_DateBaseYear" or set it directly in the global +# variable by the same name. Unix and Windows use the library's +# default value of 1970, but Macintosh used to use 1984 (I'm +# not sure if Apple have yet seen fit to conform to +# the 1970 quasi-standard). This setting doesn't matter unless you +# want your "seconds" values to be the same as your system's. +# +# GMT and local time +# ------------------ +# GMT (Greenwich Mean Time) is a universal time standard (virtually +# equivalent to "Coordinated Universal Time" (UTC), except for some +# millisecond differences). +# +# Time forms +# ---------- +# There are two fundamental date/time forms supported by this +# library: a form in which computation is easy (the "seconds" form) +# and a form in which formatting is easy (the "calendar record" +# form). +# - Seconds -- the time is be represented as an integer that is +# the number of seconds relative to the beginning of +# Cal_DateBaseYear, GMT. Cal_DateBaseYear is +# usually 1970, but can be changed). The "seconds" form is +# a universal time, independent of locale. +# - Cal_Rec -- a "calendar record", which has fields for date and +# time components: year, month, day, hour, minutes, seconds,and +# day-of-week. +# The "Cal_Rec" form is usually in terms of local time, including +# accounting for daylight savings time according to local rules. +# +# Notes +# ----- +# - Several procedures have a final "timeZone" parameter. In those +# procedures the timeZone parameter is optional and, if omitted, +# Cal_CurrentTimeZone is used. +# +# - The time zone table and list consume around 30KB that can be +# "freed" by setting both Cal_TimeZoneTable and Cal_TimeZoneList +# to &null. Procedures Cal_GetTimeZoneTable() and +# Cal_GetTimeZoneList() will re-create the structures and assign +# them back to their globals. For many applications, those +# structures are no longer needed after program initialization. +# +# - The global variables are automatically initialized by +# the Cal_ procedures. However, if you want to use the globals +# before using any procedures, they must be explicitly initialized +# by calling Cal_Init(). +# +# - Time zone records in the time zone structures should be viewed +# as read-only. If you want to make temporary changes to the +# fields, copy() the time zone record. +# +# Global variables +# ---------------- +# The following global variables are useful in date and time +# operations (R/O means please don't change it): +# +# - Cal_SecPerMin - (R/O) Seconds per minute. +# - Cal_SecPerHour - (R/O) Seconds per hour. +# - Cal_SecPerDay - (R/O) Seconds per day. +# - Cal_SecPerWeek - (R/O) Seconds per week. +# - Cal_MonthNames - (R/O) List of month names. +# - Cal_DayNames - (R/O) List of day names. +# - Cal_CurrentTimeZone - Current default time zone record -- +# can be changed at any time. Initialized +# to the time zone whose ID is in +# environment variable "Cal_TimeZone" if +# set, or to GMT. +# - Cal_TimeZoneGMT - (R/O) The GMT time zone record. Can be used +# as a timeZone parameter to "turn off" +# conversion to or from local. +# - Cal_DateBaseYear - The base year from which the "seconds" +# form is calculated, initialized to +# the value of environment variable +# "Cal_DateBaseYear" if set, or 1970 (the +# year used by both Unix and MS-Windows) +# - Cal_TimeZoneTable - A table of time zones keyed by the +# time zone's ID string +# - Cal_TimeZoneList - A list of time zones ordered by +# increasing offset from GMT +# +# Initialization procedure +# ------------------------ +# Cal_Init() +# Initializes global variables. Called implicitly by +# the Cal_ procedures. +# +# Cal_Rec (calendar record) procedures +# ------------------------------------ +# Cal_Rec(year,month,day,hour,min,sec,weekday) =20 +# Cal_Rec record constructor. All values are integers in +# customary US usage (months are 1-12, weekdays are 1-7 with +# 1 -> Sunday) +# +# Cal_SecToRec(seconds,timeZone) +# Converts seconds to a Cal_Rec, applying conversion rules +# of "timeZone". To suppress conversion, specify timeZone = +# Cal_TimeZoneGMT. +# +# Cal_RecToSec(calRec,timeZone) +# Converts a Cal_Rec to seconds, applying conversion rules +# of "timeZone". To suppress conversion, specify timeZone = +# Cal_TimeZoneGMT. +# +# Time zone procedures +# -------------------- +# Cal_GetTimeZone(timeZoneName) +# Gets a time zone given a time zone ID string. Fails if +# a time zone for the given ID cannot be produced. +# +# Cal_GetTimeZoneList() +# Returns the tine zone list that is the value of +# Cal_TimeZoneList, unless that global has been explicitly +# set to &null. If the global is null, a new list is built, +# assigned to Cal_TimeZoneList, and returned. +# +# Cal_GetTimeZoneTable() +# Returns the tine zone table that is the value of +# Cal_TimeZoneTable, unless that global has been explicitly +# set to &null. If the global is null, a new table is built, +# assigned to Cal_TimeZoneTable, and returned. In building +# the table, Cal_GetTimeZoneList() is called so global +# variable Cal_TimeZoneList is also set. +# +# Date/time calculation procedures +# -------------------------------- +# Cal_LocalToGMTSec(seconds,timeZone) +# Converts seconds from local to GMT using the rules of +# timeZone. +# +# Cal_GMTToLocalSec(seconds,timeZone) +# Converts seconds from GMT to local using the rules of +# timeZone. +# +# Cal_IsLeapYear(year) +# Returns the number of seconds in a day if year is a leap +# year, otherwise fails. +# +# Cal_LeapYearsBetween(loYear,hiYear) +# Returns the count of leap years in the range of years n +# where loYear <= n < hiYear. +# +# Cal_IsDST(seconds,timeZone) +# Returns the DST offset in hours if seconds (local time) +# is in the DST period, otherwise fails. +# +# Cal_NthWeekdayToSec(year,month,weekday,n,fromDay) +# Returns seconds of nth specified weekday of month, or fails +# if no such day. This is mainly an internal procedure for +# DST calculations, but might have other application. +# +# Date/time formatting procedures +# ------------------------------- +# Cal_DateLineToSec(dateline,timeZone) +# Converts a date in something like Icon's &dateline format +# (Wednesday, February 11, 1998 12:00 am) to "seconds" form. +# +# Cal_DateToSec(date,timeZone) +# Converts a date string in something like Icon &date format +# (1998/02/11) to "seconds" form. +# +# Cal_SecToDate(seconds,timeZone) +# Converts "seconds" form to a string in Icon's +# &date format (1998/02/11). +# +# Cal_SecToDateLine(seconds,timeZone) +# Converts "seconds" form to a string in Icon's &dateline +# format (Wednesday, February 11, 1998 12:00 am). +# +# Cal_SecToUnixDate(seconds,timeZone) +# Converts "seconds" form to a string in typical UNIX +# date/time format (Jan 14 10:24 1991). +# +# Time-only formatting procedures +# ------------------------------- +# Cal_ClockToSec(seconds) +# Converts a time in the format of &clock (19:34:56) to +# seconds past midnight. +# +# Cal_SecToClock(seconds) +# Converts seconds past midnight to a string in the format of +# &clock (19:34:56). +# +############################################################################ +# +# See also: datetime.icn, datefns.icn +# +############################################################################ + +global Cal_DateBaseYear,Cal_CurrentTimeZone,Cal_TimeZoneGMT, + Cal_SecPerMin,Cal_SecPerHour,Cal_SecPerDay,Cal_SecPerWeek, + Cal_MonthNames,Cal_DayNames,Cal_TimeZoneList,Cal_TimeZoneTable + +record Cal_Rec(year,month,day,hour,min,sec,weekday) + +record Cal_TimeZoneRec(id,hoursFromGMT,data) +record Cal_TimeZoneData(dstOffset,startYear, + startMode,startMonth,startDay,startDayOfWeek,startTime, + endMode,endMonth,endDay,endDayOfWeek,endTime) + +# +# Initialize the date globals -- although done automatically by many +# calls to date procedures, it's not a bad idea to call this explicitly +# before using. +# +procedure Cal_Init(initialTimeZone) #: initialize calendar globals + local tzTbl + initial { + Cal_SecPerMin := 60 + Cal_SecPerHour := Cal_SecPerMin * 60 + Cal_SecPerDay := Cal_SecPerHour * 24 + Cal_SecPerWeek := Cal_SecPerDay * 7 + Cal_MonthNames := ["January","February","March","April","May","June", + "July","August","September","October","November","December"] + Cal_DayNames := ["Sunday","Monday","Tuesday","Wednesday","Thursday", + "Friday","Saturday"] + /Cal_DateBaseYear := integer(getenv("Cal_DateBaseYear")) | 1970 + tzTbl := Cal_GetTimeZoneTable() + Cal_TimeZoneGMT := tzTbl["GMT"] + /Cal_CurrentTimeZone := \initialTimeZone | + tzTbl["" ~== getenv("Cal_TimeZone")] | Cal_TimeZoneGMT + } + return +end + +# +# Produces a date record computed from the seconds since the start of +# DateBaseYear. +# +procedure Cal_SecToRec(seconds,timeZone) + local day,hour,min,month,secs,weekday,year + static secPerYear + initial { + Cal_Init() + secPerYear := 365 * Cal_SecPerDay + } + seconds := integer(seconds) | runerr(101,seconds) + /timeZone := Cal_CurrentTimeZone + seconds := Cal_GMTToLocalSec(seconds,timeZone) + weekday := (seconds / Cal_SecPerDay % 7 + 4) % 7 + 1 + year := Cal_DateBaseYear + seconds / secPerYear + seconds -:= (year - Cal_DateBaseYear) * secPerYear + + Cal_LeapYearsBetween(Cal_DateBaseYear,year) * Cal_SecPerDay + while seconds < 0 do { + year -:= 1 + seconds +:= if Cal_IsLeapYear(year) then 31622400 else 31536000 + } + month := 1 + every secs := + 2678400 | + (if Cal_IsLeapYear(year) then 2505600 else 2419200) | + 2678400 | + 2592000 | + 2678400 | + 2592000 | + 2678400 | + 2678400 | + 2592000 | + 2678400 | + 2592000 | + 2678400 do { + if seconds < secs then break + month +:= 1 + seconds -:= secs + } + day := seconds / Cal_SecPerDay + 1 + seconds %:= Cal_SecPerDay + hour := seconds / Cal_SecPerHour + seconds %:= Cal_SecPerHour + min := seconds / Cal_SecPerMin + seconds %:= Cal_SecPerMin + return Cal_Rec(year,month,day,hour,min,seconds,weekday) +end + +# +# Converts a Cal_Rec to seconds since start of DateBaseYear. +# +procedure Cal_RecToSec(calRec,timeZone) + local day,hour,min,month,sec,seconds,year + static days + initial { + Cal_Init() + days := [ + 0, + 2678400, + 5097600, + 7776000, + 10368000, + 13046400, + 15638400, + 18316800, + 20995200, + 23587200, + 26265600, + 28857600] + } + /timeZone := Cal_CurrentTimeZone + year := \calRec.year | +&date[1+:4] + month := \calRec.month | +&date[6+:2] + day := \calRec.day | +&date[9+:2] + hour := \calRec.hour | 0 + min := \calRec.min | 0 + sec := \calRec.sec | 0 + seconds := ((year - Cal_DateBaseYear) * 365 + + Cal_LeapYearsBetween(Cal_DateBaseYear,year)) * Cal_SecPerDay + month > 2 & seconds +:= Cal_IsLeapYear(year) + seconds +:= days[month] + (day - 1) * Cal_SecPerDay + + hour * Cal_SecPerHour + min * Cal_SecPerMin + sec + return Cal_LocalToGMTSec(seconds,timeZone) +end + +# +# Gets the time zone record with ID "timeZoneName". +# +procedure Cal_GetTimeZone(timeZoneName) + return \Cal_GetTimeZoneTable()[timeZoneName] +end + +# +# Builds a table of time zones with keys the time zone names and values +# the time zone records (Cal_TimeZoneRec). +# +procedure Cal_GetTimeZoneTable() + local tzTbl,x + return \Cal_TimeZoneTable | { + tzTbl := table() + every x := !Cal_GetTimeZoneList() do + tzTbl[x.id] := x + Cal_TimeZoneTable := tzTbl + } +end + +# +# Builds a list of time zones ordered by increasing offset from GMT. +# +procedure Cal_GetTimeZoneList() + return \Cal_TimeZoneList | (Cal_TimeZoneList := Cal_MakeTimeZoneList()) +end + +procedure Cal_LocalToGMTSec(seconds,timeZone) + initial Cal_Init() + /timeZone := Cal_CurrentTimeZone + seconds -:= Cal_IsDST(seconds,timeZone) * Cal_SecPerHour + seconds -:= timeZone.hoursFromGMT * Cal_SecPerHour + return integer(seconds) +end + +procedure Cal_GMTToLocalSec(seconds,timeZone) + initial Cal_Init() + /timeZone := Cal_CurrentTimeZone + seconds +:= timeZone.hoursFromGMT * Cal_SecPerHour + seconds +:= Cal_IsDST(seconds,timeZone) * Cal_SecPerHour + return integer(seconds) +end + +# +# Fails unless year is a leap year. +# +procedure Cal_IsLeapYear(year) #: determine if year is leap + initial Cal_Init() + return year % 4 = 0 & (year % 100 ~= 0 | year % 400 = 0) & Cal_SecPerDay +end + +# +# Counts leap years in the range [loYear,hiYear). +# +procedure Cal_LeapYearsBetween(loYear,hiYear) + loYear -:= 1; hiYear -:= 1 + return (hiYear / 4 - loYear / 4) - + (hiYear / 100 - loYear / 100) + + (hiYear / 400 - loYear / 400) +end + +# +# If "seconds" represents a time in the DST period for the specified time +# zone, returns the number of hours by which to adjust standard time to +# daylight savings time, otherwise fails. "seconds" are local, but not +# adjusted for DST. +# +procedure Cal_IsDST(seconds,timeZone) #: determines if seconds (local) is DST + local data,calRec,year,month,startMonth,endMonth,dstOffset,result + /timeZone := Cal_CurrentTimeZone + if not (data := \timeZone.data) then fail + dstOffset := data.dstOffset + calRec := Cal_SecToRec(seconds,Cal_TimeZoneGMT) + year := calRec.year + if year < data.startYear then fail + month := calRec.month + startMonth := data.startMonth + endMonth := data.endMonth + return { + if startMonth < endMonth then + Cal_ApplyDSTRule(seconds,year,month,dstOffset, + data.startMode,startMonth,data.startDay,data.startDayOfWeek, + data.startTime, + data.endMode,endMonth,data.endDay,data.endDayOfWeek, + data.endTime - integer(dstOffset * Cal_SecPerHour)) & dstOffset + else + not Cal_ApplyDSTRule(seconds,year,month,dstOffset, + data.endMode,endMonth,data.endDay,data.endDayOfWeek, + data.endTime - integer(dstOffset * Cal_SecPerHour), + data.startMode,startMonth,data.startDay,data.startDayOfWeek, + data.startTime) & dstOffset + } +end + +# +# Calculates number of seconds on the "n"th "weekday" of "month" of "year" +# following or preceding "fromDay" (e.g. the 3rd Wednesday of April 1998 +# on or following the 5th). +# If n is negative, n is counted from the end of the month. Fails if +# the day does not exist (i.e., n is out of range for that month). +# +# The "time window" in which the day counting takes place, in the +# absense of a "fromDay", is the entire month specified. By providing a +# nonnull "fromDay", the window can be restricted to days including and +# following "fromDay" (if it is positive), or preceding (and not including, +# if it is negative). +# +# Examples: +# For first Sunday in April on or after the 5th: +# NthWeekdayToSec(1998,4,1,1,5) +# For last Sunday in October, 1998: +# NthWeekdayToSec(1998,10,1,-1) +# +procedure Cal_NthWeekdayToSec(year,month,weekday,n,fromDay) #: gets seconds of nth specified weekday of month + local startOfMonth,endOfMonth,lastDay + startOfMonth := Cal_RecToSec(Cal_Rec(year,month,1),Cal_TimeZoneGMT) + endOfMonth := Cal_RecToSec(Cal_Rec(year,month + 1,1),Cal_TimeZoneGMT) + if \fromDay then + if fromDay > 0 then + startOfMonth +:= (fromDay - 1) * Cal_SecPerDay + else if fromDay < 0 then + endOfMonth := startOfMonth + (-fromDay - 1) * Cal_SecPerDay + return { + if n > 0 then { + endOfMonth > (startOfMonth + ((weekday + 7 - + Cal_SecToRec(startOfMonth,Cal_TimeZoneGMT).weekday) % 7) * + Cal_SecPerDay + (n - 1) * Cal_SecPerWeek) + } + else if n < 0 then { + lastDay := endOfMonth - Cal_SecPerDay + startOfMonth <= (lastDay - + ((Cal_SecToRec(lastDay,Cal_TimeZoneGMT).weekday + + 7 - weekday) % 7) * Cal_SecPerDay + (n + 1) * Cal_SecPerWeek) + } + } +end + +# +# Converts a date in long form to seconds since start of DateBaseYear. +# +procedure Cal_DateLineToSec(dateline,timeZone) #: convert &dateline to seconds + local day,halfday,hour,min,month,sec,year + static months + initial { + Cal_Init() + months := table() + months["jan"] := 1 + months["feb"] := 2 + months["mar"] := 3 + months["apr"] := 4 + months["may"] := 5 + months["jun"] := 6 + months["jul"] := 7 + months["aug"] := 8 + months["sep"] := 9 + months["oct"] := 10 + months["nov"] := 11 + months["dec"] := 12 + } + map(dateline) ? { + tab(many(' \t')) + =("sun" | "mon" | "tue" | "wed" | "thu" | "fri" | "sat") & + tab(many(&letters)) | &null & tab(many(' \t,')) | &null + month := 1(tab(many(&letters)),tab(many(' \t')) | &null) + day <- integer(1(tab(many(&digits)),tab(many(' \t,')) | &null)) | &null & + year <- integer(1(tab(many(&digits)),tab(many(' \t')) | &null)) | &null & + (hour <- integer(tab(many(&digits))) & + ((=":" & min <- integer(tab(many(&digits)))) & + ((=":" & sec <- integer(tab(many(&digits)))) | &null) | &null) & + tab(many(' \t')) | &null & halfday := =("am" | "pm") | &null & + tab(many(' \t')) | &null) | &null & pos(0) + } + \month := \months[month[1+:3]] | fail + if not /(halfday | hour) then { + if hour = 12 then hour := 0 + if halfday == "pm" then + hour +:= 12 + } + return Cal_RecToSec(Cal_Rec(year,month,day,hour,min,sec),timeZone) +end + +# +# Converts a date in Icon &date format (yyyy/mm/dd) do seconds +# past DateBaseYear. +# +procedure Cal_DateToSec(date,timeZone) #: convert &date to seconds + date ? return Cal_RecToSec(Cal_Rec(+1(tab(find("/")),move(1)), + +1(tab(find("/")),move(1)),+tab(0)),timeZone) +end + +# +# Converts seconds past DateBaseYear to a &date in Icon date format +# (yyyy,mm,dd). +# +procedure Cal_SecToDate(seconds,timeZone) #: convert seconds to &date + local r + r := Cal_SecToRec(seconds,timeZone) + return right(r.year,4,"0") || "/" || right(r.month,2,"0") || "/" || + right(r.day,2,"0") +end + +# +# Produces a date in the same format as Icon's &dateline. +# +procedure Cal_SecToDateLine(seconds,timeZone) #: convert seconds to &dateline + local d,hour,halfday + d := Cal_SecToRec(seconds,timeZone) + if (hour := d.hour) < 12 then { + halfday := "am" + } + else { + halfday := "pm" + hour -:= 12 + } + if hour = 0 then hour := 12 + return Cal_DayNames[d.weekday] || ", " || Cal_MonthNames[d.month] || " " || + d.day || ", " || d.year || " " || hour || ":" || + right(d.min,2,"0") || " " || halfday +end + +# +# Returns a date and time in UNIX format: Jan 14 10:24 1991 +# +procedure Cal_SecToUnixDate(seconds,timeZone) #: convert seconds to UNIX time + local d + d := Cal_SecToRec(seconds,timeZone) + return Cal_MonthNames[d.month][1+:3] || " " || d.day || " " || + d.hour || ":" || right(d.min,2,"0") || " " || d.year +end + +# +# Converts a time in the format of &clock to seconds past midnight. +# +procedure Cal_ClockToSec(seconds) #: convert &date to seconds + seconds ? return ( + (1(tab(many(&digits)),move(1)) * 60 + + 1(tab(many(&digits)),move(1) | &null)) * 60 + + (tab(many(&digits)) | 0) + ) +end + +# +# Converts seconds past midnight to a string in the format of &clock. +# +procedure Cal_SecToClock(seconds) #: convert seconds to &clock + local sec + sec := seconds % 60 + seconds /:= 60 + return right(seconds / 60,2,"0") || ":" || right(seconds % 60,2,"0") || + ":" || right(sec,2,"0") +end + +# +# Internal procedure to help process DST rules. +# +procedure Cal_ApplyDSTRule(seconds,year,month,dstOffset, + startMode,startMonth,startDay,startDayOfWeek,startTime, + endMode,endMonth,endDay,endDayOfWeek,endTime) + if startMonth <= month <= endMonth & + (startMonth < month < endMonth | + (month = startMonth & + seconds >= Cal_DSTDayOfMonthToSec( + year,startMonth,startMode,startDay,startDayOfWeek) + + startTime) | + (month = endMonth & + seconds < Cal_DSTDayOfMonthToSec( + year,endMonth,endMode,endDay,endDayOfWeek) + + endTime)) then + return +end + +# +# Internal procedure to calculate seconds at the start of the day +# specified for DST start or end. +# +procedure Cal_DSTDayOfMonthToSec(year,month,mode,day,dayOfWeek) + return case mode of { + "dayOfMonth": Cal_RecToSec(Cal_Rec(year,month,day),Cal_TimeZoneGMT) + "dayOfWeek": Cal_NthWeekdayToSec(year,month,dayOfWeek,day) + "dayOfWeekStarting": Cal_NthWeekdayToSec(year,month,dayOfWeek,1,day) + "dayOfWeekEnding": +Cal_NthWeekdayToSec(year,month,dayOfWeek,-1,-day) + default: runerr(500) + } +end + +# +# Time zone data, ordered by increasing hoursFromGMT +# +procedure Cal_MakeTimeZoneList() + local data1,data2,data3,data4,data5,data6,data7,data8,data9,data10, + data11,data12,data13,data14,data15,data16,data17,data18,data19,data20, + data21,data22,data23,data24,data25,data26,data27,data28,data29,data30, + data31,data32,data33 + data1 := Cal_TimeZoneData(1,0,"dayOfWeekStarting",4,1,1,7200,"dayOfWeek",10,-1,1,7200) + data2 := Cal_TimeZoneData(0.5,0,"dayOfWeek",10,-1,1,0,"dayOfWeekStarting",3,1,1,0) + data3 := Cal_TimeZoneData(1,0,"dayOfWeekStarting",10,9,1,0,"dayOfWeekStarting",3,9 ,1,0) + data4 := Cal_TimeZoneData(1,0,"dayOfWeekStarting",4,1,1,0,"dayOfWeekStarting",10,8 ,1,3600) + data5 := Cal_TimeZoneData(1,0,"dayOfWeekStarting",4,1,1,3600,"dayOfWeek",10,-1,1,7200) + data6 := Cal_TimeZoneData(1,0,"dayOfWeekStarting",4,1,1,0,"dayOfWeek",10,-1,1,0) + data7 := Cal_TimeZoneData(1,0,"dayOfWeekStarting",10,1,1,0,"dayOfWeekStarting",2,11,1,0) + data8 := Cal_TimeZoneData(1,0,"dayOfWeekStarting",9,8,1,0,"dayOfWeekStarting",4,16 ,1,0) + data9 := Cal_TimeZoneData(1,0,"dayOfMonth",10,1,0,0,"dayOfMonth",3,1,0,0) + data10 := Cal_TimeZoneData(1,0,"dayOfWeek",3,-1,7,79200,"dayOfWeek",10,-1,7,79200) + data11 := Cal_TimeZoneData(1,0,"dayOfWeek",3,-1,1,0,"dayOfWeek",10,-1,1,0) + data12 := Cal_TimeZoneData(1,0,"dayOfWeek",3,-1,1,3600,"dayOfWeek",10,-1,1,3600) + data13 := Cal_TimeZoneData(1,0,"dayOfWeek",3,-1,1,7200,"dayOfWeek",10,-1,1,7200) + data14 := Cal_TimeZoneData(1,0,"dayOfWeek",3,-1,5,7200,"dayOfWeekStarting",10,1,5,10800) + data15 := Cal_TimeZoneData(1,0,"dayOfWeekStarting",9,1,1,7200,"dayOfWeekStarting",4 ,1,1,7200) + data16 := Cal_TimeZoneData(1,0,"dayOfWeek",3,-1,1,3600,"dayOfWeek",10,-1,1,7200) + data17 := Cal_TimeZoneData(1,0,"dayOfWeek",3,-1,1,7200,"dayOfWeek",10,-1,1,10800) + data18 := Cal_TimeZoneData(1,0,"dayOfWeek",3,-1,1,0,"dayOfWeek",9,-1,1,0) + data19 := Cal_TimeZoneData(1,0,"dayOfWeek",4,-1,6,3600,"dayOfWeek",9,-1,6,10800) + data20 := Cal_TimeZoneData(1,0,"dayOfWeek",3,-1,1,10800,"dayOfWeek",10,-1,1,10800) + data21 := Cal_TimeZoneData(1,0,"dayOfWeekStarting",3,15,6,0,"dayOfWeekStarting",9,1 ,1,0) + data22 := Cal_TimeZoneData(1,0,"dayOfWeekStarting",4,1,6,0,"dayOfWeekStarting",9,15 ,6,3600) + data23 := Cal_TimeZoneData(1,0,"dayOfWeek",3,-1,1,7200,"dayOfWeek",9,-1,1,10800) + data24 := Cal_TimeZoneData(1,0,"dayOfMonth",4,1,0,0,"dayOfMonth",10,1,0,0) + data25 := Cal_TimeZoneData(1,0,"dayOfMonth",4,1,0,10800,"dayOfMonth",10,1,0,14400) + data26 := Cal_TimeZoneData(1,0,"dayOfMonth",3,21,0,0,"dayOfMonth",9,23,0,0) + data27 := Cal_TimeZoneData(1,0,"dayOfWeek",3,-1,1,18000,"dayOfWeek",10,-1,1,18000) + data28 := Cal_TimeZoneData(1,0,"dayOfWeekStarting",4,7,1,0,"dayOfWeek",9,-1,1,0) + data29 := Cal_TimeZoneData(1,0,"dayOfWeek",10,-1,1,7200,"dayOfWeek",3,-1,1,10800) + data30 := Cal_TimeZoneData(0.5,0,"dayOfWeek",10,-1,1,7200,"dayOfWeek",3,-1,1,10800) + data31 := Cal_TimeZoneData(1,0,"dayOfWeek",11,-1,1,7200,"dayOfWeekStarting",3,1,1,10800) + data32 := Cal_TimeZoneData(1,0,"dayOfWeekStarting",10,1,1,7200,"dayOfWeekStarting", 3,15,1,10800) + data33 := +Cal_TimeZoneData(1,0,"dayOfWeekStarting",10,1,1,9900,"dayOfWeekStarting", 3,15,1,13500) + return [ + Cal_TimeZoneRec("Pacific/Niue",-11), + Cal_TimeZoneRec("Pacific/Apia",-11), + Cal_TimeZoneRec("MIT",-11), + Cal_TimeZoneRec("Pacific/Pago_Pago",-11), + Cal_TimeZoneRec("Pacific/Tahiti",-10), + Cal_TimeZoneRec("Pacific/Fakaofo",-10), + Cal_TimeZoneRec("Pacific/Honolulu",-10), + Cal_TimeZoneRec("HST",-10), + Cal_TimeZoneRec("America/Adak",-10,data1), + Cal_TimeZoneRec("Pacific/Rarotonga",-10,data2), + Cal_TimeZoneRec("Pacific/Marquesas",-9.5), + Cal_TimeZoneRec("Pacific/Gambier",-9), + Cal_TimeZoneRec("America/Anchorage",-9,data1), + Cal_TimeZoneRec("AST",-9,data1), + Cal_TimeZoneRec("Pacific/Pitcairn",-8.5), + Cal_TimeZoneRec("America/Vancouver",-8,data1), + Cal_TimeZoneRec("America/Tijuana",-8,data1), + Cal_TimeZoneRec("America/Los_Angeles",-8,data1), + Cal_TimeZoneRec("PST",-8,data1), + Cal_TimeZoneRec("America/Dawson_Creek",-7), + Cal_TimeZoneRec("America/Phoenix",-7), + Cal_TimeZoneRec("PNT",-7), + Cal_TimeZoneRec("America/Edmonton",-7,data1), + Cal_TimeZoneRec("America/Mazatlan",-7,data1), + Cal_TimeZoneRec("America/Denver",-7,data1), + Cal_TimeZoneRec("MST",-7,data1), + Cal_TimeZoneRec("America/Belize",-6), + Cal_TimeZoneRec("America/Regina",-6), + Cal_TimeZoneRec("Pacific/Galapagos",-6), + Cal_TimeZoneRec("America/Guatemala",-6), + Cal_TimeZoneRec("America/Tegucigalpa",-6), + Cal_TimeZoneRec("America/El_Salvador",-6), + Cal_TimeZoneRec("America/Costa_Rica",-6), + Cal_TimeZoneRec("America/Winnipeg",-6,data1), + Cal_TimeZoneRec("Pacific/Easter",-6,data3), + Cal_TimeZoneRec("America/Mexico_City",-6,data1), + Cal_TimeZoneRec("America/Chicago",-6,data1), + Cal_TimeZoneRec("CST",-6,data1), + Cal_TimeZoneRec("America/Porto_Acre",-5), + Cal_TimeZoneRec("America/Bogota",-5), + Cal_TimeZoneRec("America/Guayaquil",-5), + Cal_TimeZoneRec("America/Jamaica",-5), + Cal_TimeZoneRec("America/Cayman",-5), + Cal_TimeZoneRec("America/Managua",-5), + Cal_TimeZoneRec("America/Panama",-5), + Cal_TimeZoneRec("America/Lima",-5), + Cal_TimeZoneRec("America/Indianapolis",-5), + Cal_TimeZoneRec("IET",-5), + Cal_TimeZoneRec("America/Nassau",-5,data1), + Cal_TimeZoneRec("America/Montreal",-5,data1), + Cal_TimeZoneRec("America/Havana",-5,data4), + Cal_TimeZoneRec("America/Port-au-Prince",-5,data5), + Cal_TimeZoneRec("America/Grand_Turk",-5,data6), + Cal_TimeZoneRec("America/New_York",-5,data1), + Cal_TimeZoneRec("EST",-5,data1), + Cal_TimeZoneRec("America/Antigua",-4), + Cal_TimeZoneRec("America/Anguilla",-4), + Cal_TimeZoneRec("America/Curacao",-4), + Cal_TimeZoneRec("America/Aruba",-4), + Cal_TimeZoneRec("America/Barbados",-4), + Cal_TimeZoneRec("America/La_Paz",-4), + Cal_TimeZoneRec("America/Manaus",-4), + Cal_TimeZoneRec("America/Dominica",-4), + Cal_TimeZoneRec("America/Santo_Domingo",-4), + Cal_TimeZoneRec("America/Grenada",-4), + Cal_TimeZoneRec("America/Guadeloupe",-4), + Cal_TimeZoneRec("America/Guyana",-4), + Cal_TimeZoneRec("America/St_Kitts",-4), + Cal_TimeZoneRec("America/St_Lucia",-4), + Cal_TimeZoneRec("America/Martinique",-4), + Cal_TimeZoneRec("America/Montserrat",-4), + Cal_TimeZoneRec("America/Puerto_Rico",-4), + Cal_TimeZoneRec("PRT",-4), + Cal_TimeZoneRec("America/Port_of_Spain",-4), + Cal_TimeZoneRec("America/St_Vincent",-4), + Cal_TimeZoneRec("America/Tortola",-4), + Cal_TimeZoneRec("America/St_Thomas",-4), + Cal_TimeZoneRec("America/Caracas",-4), + Cal_TimeZoneRec("Antarctica/Palmer",-4,data3), + Cal_TimeZoneRec("Atlantic/Bermuda",-4,data1), + Cal_TimeZoneRec("America/Cuiaba",-4,data7), + Cal_TimeZoneRec("America/Halifax",-4,data1), + Cal_TimeZoneRec("Atlantic/Stanley",-4,data8), + Cal_TimeZoneRec("America/Thule",-4,data1), + Cal_TimeZoneRec("America/Asuncion",-4,data9), + Cal_TimeZoneRec("America/Santiago",-4,data3), + Cal_TimeZoneRec("America/St_Johns",-3.5,data1), + Cal_TimeZoneRec("CNT",-3.5,data1), + Cal_TimeZoneRec("America/Fortaleza",-3), + Cal_TimeZoneRec("America/Cayenne",-3), + Cal_TimeZoneRec("America/Paramaribo",-3), + Cal_TimeZoneRec("America/Montevideo",-3), + Cal_TimeZoneRec("America/Buenos_Aires",-3), + Cal_TimeZoneRec("AGT",-3), + Cal_TimeZoneRec("America/Godthab",-3,data10), + Cal_TimeZoneRec("America/Miquelon",-3,data1), + Cal_TimeZoneRec("America/Sao_Paulo",-3,data7), + Cal_TimeZoneRec("BET",-3,data7), + Cal_TimeZoneRec("America/Noronha",-2), + Cal_TimeZoneRec("Atlantic/South_Georgia",-2), + Cal_TimeZoneRec("Atlantic/Jan_Mayen",-1), + Cal_TimeZoneRec("Atlantic/Cape_Verde",-1), + Cal_TimeZoneRec("America/Scoresbysund",-1,data11), + Cal_TimeZoneRec("Atlantic/Azores",-1,data11), + Cal_TimeZoneRec("Africa/Ouagadougou",0), + Cal_TimeZoneRec("Africa/Abidjan",0), + Cal_TimeZoneRec("Africa/Accra",0), + Cal_TimeZoneRec("Africa/Banjul",0), + Cal_TimeZoneRec("Africa/Conakry",0), + Cal_TimeZoneRec("Africa/Bissau",0), + Cal_TimeZoneRec("Atlantic/Reykjavik",0), + Cal_TimeZoneRec("Africa/Monrovia",0), + Cal_TimeZoneRec("Africa/Casablanca",0), + Cal_TimeZoneRec("Africa/Timbuktu",0), + Cal_TimeZoneRec("Africa/Nouakchott",0), + Cal_TimeZoneRec("Atlantic/St_Helena",0), + Cal_TimeZoneRec("Africa/Freetown",0), + Cal_TimeZoneRec("Africa/Dakar",0), + Cal_TimeZoneRec("Africa/Sao_Tome",0), + Cal_TimeZoneRec("Africa/Lome",0), + Cal_TimeZoneRec("GMT",0), + Cal_TimeZoneRec("UTC",0), + Cal_TimeZoneRec("Atlantic/Faeroe",0,data12), + Cal_TimeZoneRec("Atlantic/Canary",0,data12), + Cal_TimeZoneRec("Europe/Dublin",0,data12), + Cal_TimeZoneRec("Europe/Lisbon",0,data12), + Cal_TimeZoneRec("Europe/London",0,data12), + Cal_TimeZoneRec("Africa/Luanda",1), + Cal_TimeZoneRec("Africa/Porto-Novo",1), + Cal_TimeZoneRec("Africa/Bangui",1), + Cal_TimeZoneRec("Africa/Kinshasa",1), + Cal_TimeZoneRec("Africa/Douala",1), + Cal_TimeZoneRec("Africa/Libreville",1), + Cal_TimeZoneRec("Africa/Malabo",1), + Cal_TimeZoneRec("Africa/Niamey",1), + Cal_TimeZoneRec("Africa/Lagos",1), + Cal_TimeZoneRec("Africa/Ndjamena",1), + Cal_TimeZoneRec("Africa/Tunis",1), + Cal_TimeZoneRec("Africa/Algiers",1), + Cal_TimeZoneRec("Europe/Andorra",1,data13), + Cal_TimeZoneRec("Europe/Tirane",1,data13), + Cal_TimeZoneRec("Europe/Vienna",1,data13), + Cal_TimeZoneRec("Europe/Brussels",1,data13), + Cal_TimeZoneRec("Europe/Zurich",1,data13), + Cal_TimeZoneRec("Europe/Prague",1,data13), + Cal_TimeZoneRec("Europe/Berlin",1,data13), + Cal_TimeZoneRec("Europe/Copenhagen",1,data13), + Cal_TimeZoneRec("Europe/Madrid",1,data13), + Cal_TimeZoneRec("Europe/Gibraltar",1,data13), + Cal_TimeZoneRec("Europe/Budapest",1,data13), + Cal_TimeZoneRec("Europe/Rome",1,data13), + Cal_TimeZoneRec("Europe/Vaduz",1,data13), + Cal_TimeZoneRec("Europe/Luxembourg",1,data13), + Cal_TimeZoneRec("Africa/Tripoli",1,data14), + Cal_TimeZoneRec("Europe/Monaco",1,data13), + Cal_TimeZoneRec("Europe/Malta",1,data13), + Cal_TimeZoneRec("Africa/Windhoek",1,data15), + Cal_TimeZoneRec("Europe/Amsterdam",1,data13), + Cal_TimeZoneRec("Europe/Oslo",1,data13), + Cal_TimeZoneRec("Europe/Warsaw",1,data16), + Cal_TimeZoneRec("Europe/Stockholm",1,data13), + Cal_TimeZoneRec("Europe/Belgrade",1,data13), + Cal_TimeZoneRec("Europe/Paris",1,data13), + Cal_TimeZoneRec("ECT",1,data13), + Cal_TimeZoneRec("Africa/Bujumbura",2), + Cal_TimeZoneRec("Africa/Gaborone",2), + Cal_TimeZoneRec("Africa/Lubumbashi",2), + Cal_TimeZoneRec("Africa/Maseru",2), + Cal_TimeZoneRec("Africa/Blantyre",2), + Cal_TimeZoneRec("Africa/Maputo",2), + Cal_TimeZoneRec("Africa/Kigali",2), + Cal_TimeZoneRec("Africa/Khartoum",2), + Cal_TimeZoneRec("Africa/Mbabane",2), + Cal_TimeZoneRec("Africa/Lusaka",2), + Cal_TimeZoneRec("Africa/Harare",2), + Cal_TimeZoneRec("CAT",2), + Cal_TimeZoneRec("Africa/Johannesburg",2), + Cal_TimeZoneRec("Europe/Sofia",2,data11), + Cal_TimeZoneRec("Europe/Minsk",2,data17), + Cal_TimeZoneRec("Asia/Nicosia",2,data18), + Cal_TimeZoneRec("Europe/Tallinn",2,data17), + Cal_TimeZoneRec("Africa/Cairo",2,data19), + Cal_TimeZoneRec("ART",2,data19), + Cal_TimeZoneRec("Europe/Helsinki",2,data20), + Cal_TimeZoneRec("Europe/Athens",2,data20), + Cal_TimeZoneRec("Asia/Jerusalem",2,data21), + Cal_TimeZoneRec("Asia/Amman",2,data22), + Cal_TimeZoneRec("Asia/Beirut",2,data18), + Cal_TimeZoneRec("Europe/Vilnius",2,data17), + Cal_TimeZoneRec("Europe/Riga",2,data23), + Cal_TimeZoneRec("Europe/Chisinau",2,data11), + Cal_TimeZoneRec("Europe/Bucharest",2,data11), + Cal_TimeZoneRec("Europe/Kaliningrad",2,data17), + Cal_TimeZoneRec("Asia/Damascus",2,data24), + Cal_TimeZoneRec("Europe/Kiev",2,data20), + Cal_TimeZoneRec("Europe/Istanbul",2,data20), + Cal_TimeZoneRec("EET",2,data20), + Cal_TimeZoneRec("Asia/Bahrain",3), + Cal_TimeZoneRec("Africa/Djibouti",3), + Cal_TimeZoneRec("Africa/Asmera",3), + Cal_TimeZoneRec("Africa/Addis_Ababa",3), + Cal_TimeZoneRec("EAT",3), + Cal_TimeZoneRec("Africa/Nairobi",3), + Cal_TimeZoneRec("Indian/Comoro",3), + Cal_TimeZoneRec("Asia/Kuwait",3), + Cal_TimeZoneRec("Indian/Antananarivo",3), + Cal_TimeZoneRec("Asia/Qatar",3), + Cal_TimeZoneRec("Africa/Mogadishu",3), + Cal_TimeZoneRec("Africa/Dar_es_Salaam",3), + Cal_TimeZoneRec("Africa/Kampala",3), + Cal_TimeZoneRec("Asia/Aden",3), + Cal_TimeZoneRec("Indian/Mayotte",3), + Cal_TimeZoneRec("Asia/Riyadh",3), + Cal_TimeZoneRec("Asia/Baghdad",3,data25), + Cal_TimeZoneRec("Europe/Simferopol",3,data20), + Cal_TimeZoneRec("Europe/Moscow",3,data17), + Cal_TimeZoneRec("Asia/Tehran",3.5,data26), + Cal_TimeZoneRec("MET",3.5,data26), + Cal_TimeZoneRec("Asia/Dubai",4), + Cal_TimeZoneRec("Indian/Mauritius",4), + Cal_TimeZoneRec("Asia/Muscat",4), + Cal_TimeZoneRec("Indian/Reunion",4), + Cal_TimeZoneRec("Indian/Mahe",4), + Cal_TimeZoneRec("Asia/Yerevan",4), + Cal_TimeZoneRec("NET",4), + Cal_TimeZoneRec("Asia/Baku",4,data27), + Cal_TimeZoneRec("Asia/Aqtau",4,data11), + Cal_TimeZoneRec("Europe/Samara",4,data17), + Cal_TimeZoneRec("Asia/Kabul",4.5), + Cal_TimeZoneRec("Indian/Kerguelen",5), + Cal_TimeZoneRec("Asia/Tbilisi",5), + Cal_TimeZoneRec("Indian/Chagos",5), + Cal_TimeZoneRec("Indian/Maldives",5), + Cal_TimeZoneRec("Asia/Dushanbe",5), + Cal_TimeZoneRec("Asia/Ashkhabad",5), + Cal_TimeZoneRec("Asia/Tashkent",5), + Cal_TimeZoneRec("Asia/Karachi",5), + Cal_TimeZoneRec("PLT",5), + Cal_TimeZoneRec("Asia/Bishkek",5,data28), + Cal_TimeZoneRec("Asia/Aqtobe",5,data11), + Cal_TimeZoneRec("Asia/Yekaterinburg",5,data17), + Cal_TimeZoneRec("Asia/Calcutta",5.5), + Cal_TimeZoneRec("IST",5.5), + Cal_TimeZoneRec("Asia/Katmandu",5.75), + Cal_TimeZoneRec("Antarctica/Mawson",6), + Cal_TimeZoneRec("Asia/Thimbu",6), + Cal_TimeZoneRec("Asia/Colombo",6), + Cal_TimeZoneRec("Asia/Dacca",6), + Cal_TimeZoneRec("BST",6), + Cal_TimeZoneRec("Asia/Alma-Ata",6,data11), + Cal_TimeZoneRec("Asia/Novosibirsk",6,data17), + Cal_TimeZoneRec("Indian/Cocos",6.5), + Cal_TimeZoneRec("Asia/Rangoon",6.5), + Cal_TimeZoneRec("Indian/Christmas",7), + Cal_TimeZoneRec("Asia/Jakarta",7), + Cal_TimeZoneRec("Asia/Phnom_Penh",7), + Cal_TimeZoneRec("Asia/Vientiane",7), + Cal_TimeZoneRec("Asia/Saigon",7), + Cal_TimeZoneRec("VST",7), + Cal_TimeZoneRec("Asia/Bangkok",7), + Cal_TimeZoneRec("Asia/Krasnoyarsk",7,data17), + Cal_TimeZoneRec("Antarctica/Casey",8), + Cal_TimeZoneRec("Australia/Perth",8), + Cal_TimeZoneRec("Asia/Brunei",8), + Cal_TimeZoneRec("Asia/Hong_Kong",8), + Cal_TimeZoneRec("Asia/Ujung_Pandang",8), + Cal_TimeZoneRec("Asia/Ishigaki",8), + Cal_TimeZoneRec("Asia/Macao",8), + Cal_TimeZoneRec("Asia/Kuala_Lumpur",8), + Cal_TimeZoneRec("Asia/Manila",8), + Cal_TimeZoneRec("Asia/Singapore",8), + Cal_TimeZoneRec("Asia/Taipei",8), + Cal_TimeZoneRec("Asia/Shanghai",8), + Cal_TimeZoneRec("CTT",8), + Cal_TimeZoneRec("Asia/Ulan_Bator",8,data18), + Cal_TimeZoneRec("Asia/Irkutsk",8,data17), + Cal_TimeZoneRec("Asia/Jayapura",9), + Cal_TimeZoneRec("Asia/Pyongyang",9), + Cal_TimeZoneRec("Asia/Seoul",9), + Cal_TimeZoneRec("Pacific/Palau",9), + Cal_TimeZoneRec("Asia/Tokyo",9), + Cal_TimeZoneRec("JST",9), + Cal_TimeZoneRec("Asia/Yakutsk",9,data17), + Cal_TimeZoneRec("Australia/Darwin",9.5), + Cal_TimeZoneRec("ACT",9.5), + Cal_TimeZoneRec("Australia/Adelaide",9.5,data29), + Cal_TimeZoneRec("Antarctica/DumontDUrville",10), + Cal_TimeZoneRec("Pacific/Truk",10), + Cal_TimeZoneRec("Pacific/Guam",10), + Cal_TimeZoneRec("Pacific/Saipan",10), + Cal_TimeZoneRec("Pacific/Port_Moresby",10), + Cal_TimeZoneRec("Australia/Brisbane",10), + Cal_TimeZoneRec("Asia/Vladivostok",10,data17), + Cal_TimeZoneRec("Australia/Sydney",10,data29), + Cal_TimeZoneRec("AET",10,data29), + Cal_TimeZoneRec("Australia/Lord_Howe",10.5,data30), + Cal_TimeZoneRec("Pacific/Ponape",11), + Cal_TimeZoneRec("Pacific/Efate",11), + Cal_TimeZoneRec("Pacific/Guadalcanal",11), + Cal_TimeZoneRec("SST",11), + Cal_TimeZoneRec("Pacific/Noumea",11,data31), + Cal_TimeZoneRec("Asia/Magadan",11,data17), + Cal_TimeZoneRec("Pacific/Norfolk",11.5), + Cal_TimeZoneRec("Pacific/Kosrae",12), + Cal_TimeZoneRec("Pacific/Tarawa",12), + Cal_TimeZoneRec("Pacific/Majuro",12), + Cal_TimeZoneRec("Pacific/Nauru",12), + Cal_TimeZoneRec("Pacific/Funafuti",12), + Cal_TimeZoneRec("Pacific/Wake",12), + Cal_TimeZoneRec("Pacific/Wallis",12), + Cal_TimeZoneRec("Pacific/Fiji",12), + Cal_TimeZoneRec("Antarctica/McMurdo",12,data32), + Cal_TimeZoneRec("Asia/Kamchatka",12,data17), + Cal_TimeZoneRec("Pacific/Auckland",12,data32), + Cal_TimeZoneRec("NST",12,data32), + Cal_TimeZoneRec("Pacific/Chatham",12.75,data33), + Cal_TimeZoneRec("Pacific/Enderbury",13), + Cal_TimeZoneRec("Pacific/Tongatapu",13), + Cal_TimeZoneRec("Asia/Anadyr",13,data17), + Cal_TimeZoneRec("Pacific/Kiritimati",14)] +end diff --git a/ipl/procs/calendat.icn b/ipl/procs/calendat.icn new file mode 100644 index 0000000..48b9d50 --- /dev/null +++ b/ipl/procs/calendat.icn @@ -0,0 +1,56 @@ +############################################################################ +# +# File: calendat.icn +# +# Subject: Procedure to get date from Julian Day Number +# +# Author: Ralph E. Griswold +# +# Date: March 25, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# calendat(j) return a record with the month, day, and year corresponding +# to the Julian Date Number j. +# +############################################################################ +# +# Acknowledgement: This procedure is based on an algorithm given in +# "Numerical Recipes; The Art of Scientific Computing"; William H. Press, +# Brian P. Flannery, Saul A. Teukolsky. and William T. Vetterling; +# Cambridge University Press, 1986. +# +############################################################################ + +record date1(month, day, year) + +procedure calendat(julian) + local ja, jalpha, jb, jc, jd, je, gregorian + local month, day, year + + gregorian := 2299161 + + if julian >= gregorian then { + jalpha := integer(((julian - 1867216) - 0.25) / 36524.25) + ja := julian + 1 + jalpha - integer(0.25 * jalpha) + } + else ja := julian + + jb := ja + 1524 + jc := integer(6680.0 + ((jb - 2439870) - 122.1) / 365.25) + jd := 365 * jc + integer(0.25 * jc) + je := integer((jb - jd) / 30.6001) + day := jb - jd - integer(30.6001 * je) + month := je - 1 + if month > 12 then month -:= 12 + year := jc - 4715 + if month > 2 then year -:= 1 + if year <= 0 then year -:= 1 + + return date1(month, day, year) + +end diff --git a/ipl/procs/calls.icn b/ipl/procs/calls.icn new file mode 100644 index 0000000..6ebb8a1 --- /dev/null +++ b/ipl/procs/calls.icn @@ -0,0 +1,154 @@ +############################################################################ +# +# File: calls.icn +# +# Subject: Procedures for calls as objects +# +# Author: Ralph E. Griswold +# +# Date: March 25, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures deal with procedure invocations that are encapsulated +# in records. +# +############################################################################ +# +# Links: ivalue, procname +# +############################################################################ + +invocable all + +link ivalue +link procname + +record call(proc, args) + +# +# Invoke a procedure with a argument list from a call record. + +procedure invoke(call) + + suspend call.proc ! call.args + +end + + +# +# Produce a string images of a call + +procedure call_image(call) + local args + + args := "" + + every args ||:= !call.args || ", " + + return procname(call.proc) || "(" || args[1:-2] || ")" + +end + + +# Make a call record from a string that looks like an invocation. +# What the arguments can be is limited to the capabilities of ivalue. + +procedure make_call(s) + local arg, args, result + + s ? { + result := call(proc(tab(upto('(')))) | fail + move(1) + result.args := make_args(tab(-1)) + } + + return result + +end + +# Make an argument list from a comma-separated string + +procedure make_args(s) + local args, arg + + args := [] + + s ? { + while arg := tab(upto(',') | 0) do { + put(args, ivalue(arg)) | fail + move(1) | break + } + } + + return args + +end + +# Produce a string of Icon code to construct a call record. + +procedure call_code(s) + local code, arg, result + + s ? { + result := "call(" || tab(upto('(')) || ", [" | fail + move(1) + while arg := tab(upto(',)')) do { + result ||:= ivalue(arg) || ", " | fail + move(1) | break + } + } + + return result[1:-2] || "])" + +end + +# Write a table of calls to a file. The file format is +# +# name=proc:arg1,arg2,arg3, ... argn, +# +# where name is the name associated with the call, proc is the +# procedure, and arg1, arg2, arg3, ... argn are the arguments. +# Note the trailing comma. + +procedure write_calltable(T, p, f) + local name + + every name := key(T) do { + writes(f, name, "=") + writes(f, procname(p), ":") + every writes(f, image(!T[name]), ",") + } + + write(f) + + return + +end + +# read a call table file into a table + +procedure read_calltable(f) + local T, line, p, args + + T := table() + + every line := read(f) do + line ? { + name := tab(upto('="')) | fail + move(1) + p := tab(upto(':')) | fail + move(1) + args := [] + while put(args, ivalue(tab(upto(',')))) do + move(1) + T[name] := call(proc(p), args) | fail + } + + return T + +end diff --git a/ipl/procs/capture.icn b/ipl/procs/capture.icn new file mode 100644 index 0000000..c23b58c --- /dev/null +++ b/ipl/procs/capture.icn @@ -0,0 +1,202 @@ +############################################################################# +# +# File: capture.icn +# +# Subject: Procedures to echo output to a second file +# +# Author: David A. Gamey +# +# Date: March 25, 2002 +# +############################################################################# +# +# This file is in the public domain. +# +############################################################################# +# +# Version: 1.0 +# +############################################################################# +# +# Capture is initially called by the user with one argument, the open file +# to contain the echoed output. Then it places itself and several shadow +# procedures between all calls to write, writes & stop. The user never +# need call capture again. +# +# Subsequently, during calls to write, writes, and stop, the appropriate +# shadow procedure gains control and calls capture internally. Capture +# then constructs a list of only those elements that direct output to +# &output and calls the original builtin function via the saved name. +# Upon return the shadow routine calls the the original builtin function +# with the full list. +# +# A series of uncaptured output functions have been added to allow output +# to be directed only to &output. These are handy for placing progress +# messages and other comforting information on the screen. +# +# Example: +# +# otherfile := open(...,"w") +# +# capfile := capture(open(filename,"w")) +# +# write("Hello there.",var1,var2," - this should be echoed", +# otherfile,"This should appear once in the other file only") +# +# uncaptured_writes("This will appear once only.") +# +# every i := 1 to 10000 do +# if ( i % 100 ) = 0 then +# +# uncaptured_writes("Progress is ",i,"\r") +# +# close(capfile) +# close(otherfile) +# +############################################################################# +# +# Notes: +# +# 1. stop must be handled specially in its shadow function +# 2. capture is not designed to be turned off +# 3. This may be most useful in systems other than Unix +# (i.e. that don't have a "tee" command) +# 4. Display has not been captured because +# a) display is usually a debugging aid, and capture was +# originally intended to capture screen output to a file +# where a record or audit trail might be required +# b) the display output would be 'down a level' showing the +# locals at the display_capture_ level, although the depth +# argument could easily be incremented to adjust for this +# c) write, writes, and stop handle arguments the same way +# 5. An alternative to having two calls would be to have capture +# call the desired procedure with : +# push(&output,x) ; return p!(y ||| x ) +# While this would remove the complexity with stop it would +# probably be slower +# +############################################################################# +# +# History: +# +# 10Jun94 - D.Gamey - added uncaptured i/o routines +# 05Oct94 - D.Gamey - temporarily suspend tracing +# 20Oct94 - D.Gamey - fix no output for f(&null) +# - eliminated global variable and select procedure +# +############################################################################# + +procedure capture(p,x) + +local keepxi # used in list copy to keep/discard arguments +local xi # equivalent to x[i] +local y # list to hold what needs be echoed + +static f # alternate file to echo to + +case type(p) of +{ + "procedure" : + { + # Internal use, support for (write|writes|stop)_capture_ procedures + + runerr(/f & 500) # ensure capture(f) called first + + keepxi := 1 # default is to keep elements + y := [] # list for captured elements + + every xi := !x do + { + if xi === &output then + keepxi := 1 # copying arguments after &output + else + if type(xi) == "file" then + keepxi := &null # ignore arguments after non-&output + else + if \keepxi then # if copying ... + put(y,xi) # append data element from x to y + } + + if ( *y > 0 ) | ( *x = 0 ) then + { + push(y,f) # target output to second file + return 1( p!y, y := &null ) # write it & trash list + } + } + + "null" : + { + # Internal use, succeeds if capture is active, fails otherwise + + if /f then + fail + else + return + + } + + "file" : + { + # This case is called externally to establish the capture + # and switch places with the regular routines. + # Normally this is called only once, however + # it can be called subsequently to switch the capture file + + if /f then # swap procedures first time only + { + write :=: write_capture_ + writes :=: writes_capture_ + stop :=: stop_capture_ + } + return f := p # save file for future use + } +} +end +#subtitle Support procedures to intercept write, writes, and stop +# these procedures get capture to echo text destined for &output +# then call the original routine. + +procedure write_capture_(x[]) +local tr + +tr := &trace ; &trace := 0 # suspend tracing +capture(write_capture_,x) +return 1( write_capture_!x, &trace := tr ) +end + +procedure writes_capture_(x[]) +local tr + +tr := &trace ; &trace := 0 # suspend tracing +capture(writes_capture_,x) +return 1( writes_capture_!x, &trace := tr ) +end + +procedure stop_capture_(x[]) +local tr + +tr := &trace ; &trace := 0 # suspend tracing +capture(write_capture_,x) # write, otherwise we stop too soon +return 1( stop_capture_!x, &trace := tr ) # restore trace just in case 'stop' is changed +end +#subtitle Support procedures to provide uncaptured output +procedure uncaptured_write(x[]) +local tr + +tr := &trace ; &trace := 0 # suspend tracing +return 1( ((capture() & write_capture_) | write)!x, &trace := tr ) +end + +procedure uncaptured_writes(x[]) +local tr + +tr := &trace ; &trace := 0 # suspend tracing +return 1( ((capture() & writes_capture_) | writes)!x, &trace := tr ) +end + +procedure uncaptured_stop(x[]) +local tr + +tr := &trace ; &trace := 0 # suspend tracing +return 1( ((capture() & stop_capture_) | stop)!x, &trace := tr ) # j.i.c. +end diff --git a/ipl/procs/cartog.icn b/ipl/procs/cartog.icn new file mode 100644 index 0000000..010ebc9 --- /dev/null +++ b/ipl/procs/cartog.icn @@ -0,0 +1,533 @@ +############################################################################ +# +# File: cartog.icn +# +# Subject: Procedures for cartographic projection +# +# Authors: Gregg M. Townsend and William S. Evans +# +# Date: February 19, 2003 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures project geographic coordinates. +# +# rectp(x1, y1, x2, y2, xm, ym) defines a rectangular projection. +# pptrans(L1, L2) defines a planar projective transformation. +# utm(a, f) defines a latitude/longitude to UTM projection. +# +# project(p, L) projects a list of coordinates. +# invp(p) returns the inverse of projection p. +# compose(p1, p2, ...) creates a composite projection. +# +############################################################################ +# +# rectp(x1, y1, x2, y2, xm, ym) returns a rectangular projection +# in which the point (x1, y1) maps to (x2, y2). If xm is specified, +# distances in the projected coordinate system are scaled by xm. If +# ym is also specified, xm scales x values while ym scales y values. +# +############################################################################ +# +# pptrans(L1, L2) returns a planar projective transform that maps +# the four points in L1 to the four points in L2. Each of the two +# lists contains 8 coordinates: [x1, y1, x2, y2, x3, y3, x4, y4]. +# +############################################################################ +# +# utm(a, f) returns a projection from latitude and longitude to +# Universal Transverse Mercator (UTM) representation. The reference +# ellipsoid is specified by a, the equatorial radius in metres, and f, +# the flattening. Alternatively, f can be omitted with a specifying +# a string, such as "Clarke66"; if a is also omitted, "WGS84" is used. +# See ellipsoid() in geodat.icn for the list of possible strings. +# +# The input list contains signed numeric values: longitude and +# latitude, in degrees, in that order (x before y). The output list +# contains triples: an integer zone number followed by real-valued +# UTM x and y distances in metres. No "false easting" is applied. +# +# UTM conversions are valid between latitudes 72S and 84N, except +# for those portions of Norway where the UTM grid is irregular. +# +############################################################################ +# +# project(p, L) applies a projection, reading a list of coordinates +# and returning a new list of transformed coordinates. +# +############################################################################ +# +# invp(p) returns the inverse of projection p, or fails if no +# inverse projection is available. +# +############################################################################ +# +# compose(p1, p2, ..., pn) returns the projection that is the +# composition of the projections p1, p2, ..., pn. The composition +# applies pn first. +# +############################################################################ +# +# sbsize(p, x, y, u, maxl) calculates a scale bar size for use with +# projection p at input coordinates (x, y). Given u, the size of +# an unprojected convenient unit (meter, foot, mile, etc.) at (x, y), +# sbsize() returns the maximum "round number" N such that +# -- N is of the form i * 10 ^ k for i in {1,2,3,4,5} +# -- the projected length of the segment (x, y, x + N * u, y) +# does not exceed maxl +# +############################################################################ +# +# UTM conversion algorithms are based on: +# +# Map Projections: A Working Manual +# John P. Snyder +# U.S. Geological Survey Professional Paper 1395 +# Washington: Superintendent of Documents, 1987 +# +# Planar projective transformation calculations come from: +# +# Computing Plane Projective Transformations (Method 1) +# Andrew Zisserman, Robotics Research Group, Oxford +# in CVOnline (R. Fisher, ed.), found 22 February 2000 at: +# http://www.dai.ed.ac.uk/CVonline/LOCAL_COPIES/EPSRC_SSAZ/node11.html +# +############################################################################ +# +# Links: geodat, io, lu, numbers, strings +# +############################################################################ + + + +link geodat +link io +link lu +link numbers +link strings + + + +# Procedures and globals named with a "ctg_" prefix are +# not intended for access outside this file. + +global ctg_eps_ptab # table of [axis, flatng], keyed by eps name + + + +#################### General Projection Support #################### + + + +# project(p, L) projects a list of coordinates, returning a new list. + +procedure project(p, L) #: project a list of coordinates + return p.proj(p, L) +end + + + +# invp(p) returns the inverse of projection p. + +procedure invp(p) #: return inversion of projection + return (\p.inv)(p) +end + + + +# sbsize(p, x, y, u, maxl) -- calculate scalebar size + +procedure sbsize(p, x, y, u, maxl) #: calculate scalebar size + local d, i, m, r + + m := 1 + repeat { + r := project(p, [x, y, x + m * u, y]) + d := r[3] - r[1] + if d > maxl then + m := m / 10.0 + else if d * 10 >= maxl + then break + else + m := m * 10 + } + + if maxl >= d * (i := 5 | 4 | 3 | 2) then + m *:= i + + return m +end + + + + +#################### Rectangular Projection #################### + + + +record ctg_rect( # rectangular projection record + proj, # projection procedure + inv, # inversion procedure + xmul, # x multiplier + ymul, # y multiplier + xadd, # x additive factor + yadd # y additive factor + ) + + + +# rectp(x1, y1, x2, y2, xm, ym) -- define rectangular projection + +procedure rectp(x1, y1, x2, y2, xm, ym) #: define rectangular projection + local p + + /xm := 1.0 + /ym := xm + p := ctg_rect() + p.proj := ctg_rect_proj + p.inv := ctg_rect_inv + p.xmul := real(xm) + p.ymul := real(ym) + p.xadd := x2 - x1 * xm + p.yadd := y2 - y1 * ym + return p +end + + + +# ctg_rect_proj(p, L) -- project using rectangular projection + +procedure ctg_rect_proj(p, L) + local i, a, xmul, ymul, xadd, yadd + + a := list() + xmul := p.xmul + ymul := p.ymul + xadd := p.xadd + yadd := p.yadd + every i := 1 to *L by 2 do { + put(a, xmul * L[i] + xadd) + put(a, ymul * L[i+1] + yadd) + } + return a +end + + + +# ctg_rect_inv(p) -- invert rectangular projection + +procedure ctg_rect_inv(p) + local q + + q := copy(p) + q.xmul := 1.0 / p.xmul + q.ymul := 1.0 / p.ymul + q.xadd := -p.xadd / p.xmul + q.yadd := -p.yadd / p.ymul + return q +end + + + +################ Planar Projective Transformation ############### + + + +record ctg_ppt( # planar projective transformation record + proj, # projection procedure + inv, # inversion procedure + org, # origin points + tgt, # target points + h11, h12, h13, # transformation matrix: (x' y' 1) = H (x y 1) + h21, h22, h23, + h31, h32, h33 + ) + + + +# pptrans(L1, L2) -- define planar projective transformation + +procedure pptrans(L1, L2) #: define planar projective transformation + local p, M, I, B + local x1, x2, x3, x4, y1, y2, y3, y4 + local x1p, x2p, x3p, x4p, y1p, y2p, y3p, y4p + + *L1 = 8 | runerr(205, L1) + *L2 = 8 | runerr(205, L2) + + p := ctg_ppt() + p.proj := ctg_ppt_proj + p.inv := ctg_ppt_inv + p.org := copy(L1) + p.tgt := copy(L2) + + B := copy(L1) + every (x1 | y1 | x2 | y2 | x3 | y3 | x4 | y4) := get(B) + B := copy(L2) + every (x1p | y1p | x2p | y2p | x3p | y3p | x4p | y4p) := get(B) + + M := [ + [ x1, y1, 1., 0., 0., 0., -x1p * x1, -x1p * y1], + [ 0., 0., 0., x1, y1, 1., -y1p * x1, -y1p * y1], + [ x2, y2, 1., 0., 0., 0., -x2p * x2, -x2p * y2], + [ 0., 0., 0., x2, y2, 1., -y2p * x2, -y2p * y2], + [ x3, y3, 1., 0., 0., 0., -x3p * x3, -x3p * y3], + [ 0., 0., 0., x3, y3, 1., -y3p * x3, -y3p * y3], + [ x4, y4, 1., 0., 0., 0., -x4p * x4, -x4p * y4], + [ 0., 0., 0., x4, y4, 1., -y4p * x4, -y4p * y4] + ] + I := list(8) + B := copy(L2) + + lu_decomp(M, I) | fail # if singular, fail + lu_back_sub(M, I, B) + every (p.h11 | p.h12 | p.h13 | p.h21 | p.h22 | p.h23 | p.h31 | p.h32) := + get(B) + p.h33 := 1.0 + + return p +end + + + +# ctg_ppt_proj(p, L) -- project using planar projective transformation + +procedure ctg_ppt_proj(p, L) + local a, i, x, y, d, h11, h12, h13, h21, h22, h23, h31, h32, h33 + + h11 := p.h11 + h12 := p.h12 + h13 := p.h13 + h21 := p.h21 + h22 := p.h22 + h23 := p.h23 + h31 := p.h31 + h32 := p.h32 + h33 := p.h33 + a := list() + + every i := 1 to *L by 2 do { + x := L[i] + y := L[i+1] + d := h31 * x + h32 * y + h33 + put(a, (h11 * x + h12 * y + h13) / d, (h21 * x + h22 * y + h23) / d) + } + + return a +end + + + +# ctg_ppt_inv(p, L) -- invert planar projective transformation + +procedure ctg_ppt_inv(p) + return pptrans(p.tgt, p.org) +end + + + +############### Universal Transverse Mercator Projection ############### + + + +# UTM conversion parameters + +$define k0 0.9996 # central meridian scaling factor for UTM +$define M0 0.0 # M0 = 0 because y origin is at phi=0 + + +record ctg_utm( # UTM projection record + proj, # projection procedure + inv, # inversion procedure + a, # polar radius + f, # flattening + e, # eccentricity + esq, # eccentricity squared + epsq, # e prime squared + c0, c2, c4, c6, c8 # other conversion constants + ) + + + +# utm(a, f) -- define UTM projection + +procedure utm(a, f) #: define UTM projection + local p, e, af + + p := ctg_utm() + p.proj := ctg_utm_proj + p.inv := ctg_utm_inv + + if /f then { + af := ellipsoid(a) | fail + a := af[1] + f := af[2] + } + p.a := a # p.a = equatorial radius + p.f := f # p.f = flattening + p.esq := 2 * f - f ^ 2 # p.esq = eccentricity squared + p.epsq := p.esq / (1 - p.esq) + p.e := sqrt(p.esq) # p.e = eccentricity + p.c0 := p.a * (1 - (p.e^2) / 4 - 3 * (p.e^4) / 64 - 5 * (p.e^6) / 256) + p.c2 := p.a * (3 * (p.e^2) / 8 + 3 * (p.e^4) / 32 + 45 * (p.e^6) / 1024) + p.c4 := p.a * (15 * (p.e^4) / 256 + 45 * (p.e^6) / 1024) + p.c6 := p.a * (35 * (p.e^6) / 3072) + return p +end + + + +# ctg_utm_proj(p, L) -- project using UTM projection (Snyder, p61) + +procedure ctg_utm_proj(p, L) + local ulist, epsq, lat, lon, zone, phi, lambda, lamzero, cosphi + local i, N, T, C, A, M, x, u, y + + ulist := list() + epsq := p.epsq + + every i := 1 to *L by 2 do { + lon := numeric(L[i]) + lat := numeric(L[i+1]) + zone := (185 + integer(lon)) / 6 + phi := dtor(lat) # latitude in radians + lambda := dtor(lon) # longitude in radians + lamzero := dtor(-183 + 6 * zone) # central meridian of zone + N := p.a / sqrt(1 - p.esq * sin(phi) ^ 2) # (8-12) + T := tan(phi) ^ 2 # (4-20) + cosphi := cos(phi) + C := epsq * cosphi ^ 2 # (8-13) + A := (lambda - lamzero) * cosphi # (8-15) + M := p.c0*phi - p.c2*sin(2.*phi) + p.c4*sin(4.*phi) - p.c6*sin(6.*phi) + x := k0 * N * (A + (1 - T + C) * A^3 / 6. + + (5. - 18. * T + T^2 + 72. * C - 58. * epsq) * A^5 / 120.) + u := A^2 / 2 + (5 - T + 9 * C + 4 * C^2) * A^4 / 24 + + (61. - 58. * T + T^2 + 600. * C - 330. * epsq) * A^6 / 720. + y := k0 * (M - M0 + N * tan(phi) * u) + put(ulist, zone, x, y) + } + return ulist +end + + + +# ctg_utm_inv(p) -- invert UTM projection + +procedure ctg_utm_inv(p) + local q, e, e1 + + q := copy(p) + q.proj := ctg_iutm_proj + q.inv := ctg_iutm_inv + e := q.e + e1 := (1 - sqrt(1 - e^2)) / (1 + sqrt(1 - e^2)) + q.c0 := q.a * (1 - e^2 / 4. - 3. * e^4 / 64. - 5. * e^6 / 256.) + q.c2 := 3. * e1 / 2. - 27. * e1^3 / 32. + q.c4 := 21. * e1^2 / 16. - 55. * e1^4 / 32. + q.c6 := 151. * e1^3 / 96. + q.c8 := 1097. * e1^4 / 512. + return q +end + + + +# ctg_iutm_proj(p, L) -- project using inverse UTM projection (Snyder, p63) + +procedure ctg_iutm_proj(p, L) + local a, esq, epsq + local lllist, i, x, y, zone + local lam0, mu, phi1, sin1, cos1, tan1, phi, lam, t1, t2, C1, T1, N1, R1, D + + a := p.a + esq := p.esq + epsq := p.epsq + lllist := list() + + every i := 1 to *L by 3 do { + zone := L[i] + x := L[i + 1] + y := L[i + 2] + lam0 := dtor(-183 + 6 * zone) # central meridian of zone + mu := y / (k0 * p.c0) + phi1 := mu + p.c2 * sin(2. * mu) + p.c4 * sin(4. * mu) + + p.c6 * sin(6. * mu) + p.c8 * sin(8. * mu) + sin1 := sin(phi1) + cos1 := cos(phi1) + tan1 := tan(phi1) + t1 := 1 - esq * sin1^2 + t2 := sqrt(t1) + C1 := epsq * cos1^2 + T1 := tan1^2 + N1 := a / t2 + R1 := a * (1 - esq) / (t1 * t2) + D := x / (N1 * k0) + phi := phi1 - (N1 * tan1 / R1) * + (D^2 / 2. - (5. + 3.*T1 + 10.*C1 - 4.*C1*C1 - 9.*epsq) * D^4 / 24. + + (61. + 90.*T1 + 298.*C1 + 45.*T1*T1 - 252.*epsq - 3. * C1*C1) * + D^6 / 720.) + lam := lam0 + (D - (1 + 2 * T1 + C1) * D^3 / 6. + + (5. - 2. * C1 + 28. * T1 - 3. * C1 * C1 + + 8. * epsq + 24. * T1 * T1) * D^5 / 120.) / cos1 + put(lllist, rtod(lam), rtod(phi)) + } + + return lllist +end + + + +# ctg_iutm_inv(p, L) -- invert inverse UTM projection + +procedure ctg_iutm_inv(p) + return utm(p.a, p.f) +end + + + +################## Composing projections ############################# + +record ctg_comp( # composition of two projections + proj, # projection procedure (always ctg_comp_proj) + inv, # inverse (always ctg_comp_inv) + projList # list of projections in composition, + # first is applied first, etc. + ) + +# compose -- produce a projection that applies the LAST projection +# in a[] first, etc. + +procedure compose(a[]) #: define composite projection + local q, r + + q := ctg_comp() + q.proj := ctg_comp_proj + q.inv := ctg_comp_inv + q.projList := [] + every r := !a do + push(q.projList, r) + return q +end + +procedure ctg_comp_proj(p, L) + local r + + every r := !(p.projList) do + L := project(r, L) + return L +end + +procedure ctg_comp_inv(p) + local q, r + + q := ctg_comp() + q.proj := ctg_comp_proj + q.inv := ctg_comp_inv + q.projList := [] + every r := !(p.projList) do + push(q.projList, invp(r)) + return q +end diff --git a/ipl/procs/caseless.icn b/ipl/procs/caseless.icn new file mode 100644 index 0000000..29e4d0d --- /dev/null +++ b/ipl/procs/caseless.icn @@ -0,0 +1,132 @@ +############################################################################ +# +# File: caseless.icn +# +# Subject: Procedures to perform caseless scanning +# +# Author: Nevin J. Liber +# +# Date: August 19, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures are analogous to the standard string-analysis +# functions except that uppercase letters are considered equivalent to +# lowercase letters. +# +# anycl(c, s, i1, i2) succeeds and produces i1 + 1, provided +# map(s[i1]) is in cset(map(c)) and i2 is +# greater than i1. It fails otherwise. +# +# balcl(c1, c2, c3, s, i1, i2) generates the sequence of integer +# positions in s preceding a +# character of cset(map(c1)) in +# map(s[i1:i2]) that is balanced with +# respect to characters in cset(map(c2)) +# and cset(map(c3)), but fails if there +# is no such position. +# +# findcl(s1, s2, i1, i2) generates the sequence of integer positions in +# s2 at which map(s1) occurs as a substring +# in map(s2[i1:i2]), but fails if there is no +# such position. +# +# manycl(c, s, i1, i2) succeeds and produces the position in s +# after the longest initial sequence of +# characters in cset(map(c)) within +# map(s[i1:i2]). It fails if map(s[i1]) is not +# in cset(map(c)). +# +# matchcl(s1, s2, i1, i2) produces i1 + *s1 if +# map(s1) == map(s2[i1+:=*s1]) but fails +# otherwise. +# +# uptocl(c, s, i1, i2) generates the sequence of integer positions in +# s preceding a character of cset(map(c)) in +# map(s[i1:i2]). It fails if there is no such +# position. +# +# Defaults: s, s2 &subject +# i1 &pos if s or s2 is defaulted; otherwise 1 +# i2 0 +# c1 &cset +# c2 '(' +# c3 ')' +# +# Errors: 101 i1 or i2 not integer +# 103 s or s1 or s2 not string +# 104 c or c1 or c2 or c3 not cset +# +################################################################################ + + +procedure anycl(c, s, i1, i2) #: Caseless version of any() + + c := cset(map(cset(c))) + /i1 := (/s & &pos) + s := map(string(s) | (/s & &subject)) + + return any(c, s, i1, i2) + +end + + +procedure balcl(c1, c2, c3, s, i1, i2) #: Caseless version of bal() + + c1 := cset(map(cset(c1))) + c2 := cset(map(cset(c2))) + c3 := cset(map(cset(c3))) + /i1 := (/s & &pos) + s := map(string(s) | (/s & &subject)) + + suspend bal(c1, c2, c3, s, i1, i2) + +end + + +procedure findcl(s1, s2, i1, i2) #: Caseless version of find() + + s1 := map(string(s1)) + /i1 := (/s2 & &pos) + s2 := map(string(s2) | (/s2 & &subject)) + + suspend find(s1, s2, i1, i2) + +end + + +procedure manycl(c, s, i1, i2) #: Caseless version of many() + + c := cset(map(cset(c))) + /i1 := (/s & &pos) + s := map(string(s) | (/s & &subject)) + + return many(c, s, i1, i2) + +end + + +procedure matchcl(s1, s2, i1, i2) #: Caseless version of match() + + s1 := map(string(s1)) + /i1 := (/s2 & &pos) + s2 := map(string(s2) | (/s2 & &subject)) + + return match(s1, s2, i1, i2) + +end + + +procedure uptocl(c, s, i1, i2) #: Caseless version of upto() + + c := cset(map(cset(c))) + /i1 := (/s & &pos) + s := map(string(s) | (/s & &subject)) + + suspend upto(c, s, i1, i2) + +end diff --git a/ipl/procs/codeobj.icn b/ipl/procs/codeobj.icn new file mode 100644 index 0000000..7fb780a --- /dev/null +++ b/ipl/procs/codeobj.icn @@ -0,0 +1,251 @@ +############################################################################ +# +# File: codeobj.icn +# +# Subject: Procedures to encode and decode Icon data +# +# Author: Ralph E. Griswold +# +# Date: March 25, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures provide a way of storing Icon values as strings and +# retrieving them. The procedure encode(x) converts x to a string s that +# can be converted back to x by decode(s). These procedures handle all +# kinds of values, including structures of arbitrary complexity and even +# loops. For "scalar" types -- null, integer, real, cset, and string -- +# +# decode(encode(x)) === x +# +# For structures types -- list, set, table, and record types -- +# decode(encode(x)) is, for course, not identical to x, but it has the +# same "shape" and its elements bear the same relation to the original +# as if they were encoded and decode individually. +# +# No much can be done with files, functions and procedures, and +# co-expressions except to preserve type and identification. +# +# The encoding of strings and csets handles all characters in a way +# that it is safe to write the encoding to a file and read it back. +# +# No particular effort was made to use an encoding of value that +# minimizes the length of the resulting string. Note, however, that +# as of Version 7 of Icon, there are no limits on the length of strings +# that can be written out or read in. +# +############################################################################ +# +# The encoding of a value consists of four parts: a tag, a length, +# a type code, and a string of the specified length that encodes the value +# itself. +# +# The tag is omitted for scalar values that are self-defining. +# For other values, the tag serves as a unique identification. If such a +# value appears more than once, only its tag appears after the first encoding. +# There is, therefore, a type code that distinguishes a label for a previously +# encoded value from other encodings. Tags are strings of lowercase +# letters. Since the tag is followed by a digit that starts the length, the +# two can be distinguished. +# +# The length is simply the length of the encoded value that follows. +# +# The type codes consist of single letters taken from the first character +# of the type name, with lower- and uppercase used to avoid ambiguities. +# +# Where a structure contains several elements, the encodings of the +# elements are concatenated. Note that the form of the encoding contains +# the information needed to separate consecutive elements. +# +# Here are some examples of values and their encodings: +# +# x encode(x) +# ------------------------------------------------------- +# +# 1 "1i1" +# 2.0 "3r2.0" +# &null "0n" +# "\377" "4s\\377" +# '\376\377' "8c\\376\\377" +# procedure main "a4pmain" +# co-expression #1 (0) "b0C" +# [] "c0L" +# set() "d0S" +# table("a") "e3T1sa" +# L1 := ["hi","there"] "f11L2shi5sthere" +# +# A loop is illustrated by +# +# L2 := [] +# put(L2,L2) +# +# for which +# +# x encode(x) +# ------------------------------------------------------- +# +# L2 "g3L1lg" +# +# Of course, you don't have to know all this to use encode and decode. +# +############################################################################ +# +# Links: escape, gener, procname, typecode +# +############################################################################ +# +# Requires: co-expressions +# +############################################################################ + +invocable all + +link escape, gener, procname, typecode + +global outlab, inlab + +record triple(type,value,tag) + +# Encode an arbitary value as a string. +# +procedure encode(x,level) + local str, tag, Type + static label + initial label := create "l" || star(string(&lcase)) + if /level then outlab := table() # table is global, but reset at + # each root call. + tag := "" + Type := typecode(x) + if Type == !"ri" then str := string(x) # first the scalars + else if Type == !"cs" then str := image(string(x))[2:-1] # remove quotes + else if Type == "n" then str := "" + else if Type == !"LSRTfpC" then # next the structures and other types + if str := \outlab[x] then # if the object has been processed, + Type := "l" # use its label and type it as label. + else { + tag := outlab[x] := @label # else make a label for it. + str := "" + if Type == !"LSRT" then { # structures + every str ||:= encode( # generate, recurse, and concatenate + case Type of { + !"LS": !x # elements + "T": x[[]] | !sort(x,3) # default, then elements + "R": type(x) | !x # type then elements + } + ,1) # indicate internal call + } + else str ||:= case Type of { # other things + "f": image(x) + "C": "" + "p": procname(x) + } + } + else stop("unsupported type in encode: ",image(x)) + return tag || *str || Type || str +end + +# Generate decoded results. At the top level, there is only one, +# but for structures, it is called recursively and generates the +# the decoded elements. +# +procedure decode(s,level) + local p + if /level then inlab := table() # global but reset + every p := separ(s) do { + suspend case p.type of { + "l": inlab[p.value] # label for an object + "i": integer(p.value) + "s": escape(p.value) + "c": cset(escape(p.value)) + "r": real(p.value) + "n": &null + "L": delist(p.value,p.tag) + "R": derecord(p.value,p.tag) + "S": deset(p.value,p.tag) + "T": detable(p.value,p.tag) + "f": defile(p.value) + "C": inlab[p.tag] := create &fail # can't hurt much to fail + "p": inlab[p.tag] := (proc(p.value) | + stop("encoded procedure not found")) \ 1 + default: stop("unexpected type in decode: ",p.type) + } + } +end + +# Generate triples for the encoded values in concatenation. +# +procedure separ(s) + local p, size + + while *s ~= 0 do { + p := triple() + s ?:= { + p.tag := tab(many(&lcase)) + size := tab(many(&digits)) | break + p.type := move(1) + p.value := move(size) + tab(0) + } + suspend p + } +end + +# Decode a list. The newly constructed list is added to the table that +# relates tags to structure values. +# +procedure delist(s,tag) + local a + inlab[tag] := a := [] # insert object for label + every put(a,decode(s,1)) + return a +end + +# Decode a set. Compare to delist above. +# +procedure deset(s,tag) + local S + inlab[tag] := S := set() + every insert(S,decode(s,1)) + return S +end + +# Decode a record. +# +procedure derecord(s,tag) + local R, e + e := create decode(s,1) # note use of co-expressions to control + # generation, since record must be constructed + # before fields are produced. + inlab[tag] := R := proc(@e)() | stop("error in decoding record") + every !R := @e + return R +end + +# Decode a table. +# +procedure detable(s,tag) + local t, e + e := create decode(s,1) # see derecord above; here it's the default + # value that motivates co-expressions. + inlab[tag] := t := table(@e) + while t[@e] := @e + return t +end + +# Decode a file. +# +procedure defile(s, tag) + return inlab[tag] := case s of { # files aren't so simple ... + "&input": &input + "&output": &output + "&errout": &errout + default: s ? { + ="file(" # open for reading to play it safe + open(tab(upto(')'))) | stop("cannot open encoded file") + } + } +end diff --git a/ipl/procs/colmize.icn b/ipl/procs/colmize.icn new file mode 100644 index 0000000..7909e2d --- /dev/null +++ b/ipl/procs/colmize.icn @@ -0,0 +1,107 @@ +############################################################################ +# +# File: colmize.icn +# +# Subject: Procedures to arrange data into columns +# +# Author: Robert J. Alexander +# +# Date: June 15, 1990 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# colmize() -- Arrange data into columns. +# +# Procedure to arrange a number of data items into multiple columns. +# Items are arranged in column-wise order, that is, the sequence runs +# down the first column, then down the second, etc. +# +# This procedure goes to great lengths to print the items in as few +# vertical lines as possible. +# +############################################################################ + +procedure colmize(entries,maxcols,space,minwidth,tag,tagspace,tagminwidth,rowwise,distribute) + local mean,cols,lines,width,i,x,wid,extra,t,j,first_tagfield,tagfield + # + # Process arguments -- provide defaults. + # + # entries: a list of items to be columnized + /maxcols := 80 # max width of output lines + /space := 2 # min nbr of spaces between columns + /minwidth := 0 # min column width + # tag: a label to be placed on the first line of output + /tagminwidth := 0 + /tagspace := 2 + # rowwise: if nonnull, entries are listed in rowwise order rather than + # columnwise + # + # + # Process the tag field information. The tag will appear on the + # first line to the left of the data. + # + if \tag then { + tagminwidth <:= *tag + tagspace + maxcols -:= tagminwidth + first_tagfield := left(tag, tagminwidth - tagspace) || repl(" ",tagspace) + tagfield := repl(" ",tagminwidth) + } else + tagfield := first_tagfield := "" + # Starting with a trial number-of-columns that is guaranteed + # to be too wide, successively reduce the number until the + # items can be packed into the allotted width. + # + mean := 0 + every mean +:= *!entries + mean := mean / (0 ~= *entries) | 1 + every cols := (maxcols + space) * 2 / (mean + space) to 1 by -1 do { + lines := (*entries + cols - 1) / cols + width := list(cols,minwidth) + i := 0 + if /rowwise then { # if column-wise + every x := !entries do { + width[i / lines + 1] <:= *x + space + i +:= 1 + } + } + else { # else row-wise + every x := !entries do { + width[i % cols + 1] <:= *x + space + i +:= 1 + } + } + wid := 0 + every x := !width do wid +:= x + if wid <= maxcols + space then break + } + # + # Now output the data in columns. + # + extra := (\distribute & (maxcols - wid) / (0 < cols - 1)) | 0 + if /rowwise then { # if column-wise + every i := 1 to lines do { + if i = 1 then + t := first_tagfield + else + t := tagfield + every j := 0 to cols - 1 do + t ||:= left(entries[i + j * lines],width[j + 1] + extra) + suspend trim(t) + } + } + else { # else row-wise + every i := 0 to lines - 1 do { + if i = 0 then + t := first_tagfield + else + t := tagfield + every j := 1 to cols do + t ||:= left(entries[j + i * cols],width[j] + extra) + suspend trim(t) + } + } +end diff --git a/ipl/procs/complete.icn b/ipl/procs/complete.icn new file mode 100644 index 0000000..e6e30de --- /dev/null +++ b/ipl/procs/complete.icn @@ -0,0 +1,164 @@ +############################################################################ +# +# File: complete.icn +# +# Subject: Procedure to complete partial input string +# +# Author: Richard L. Goerwitz +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.7 +# +############################################################################ +# +# complete(s,st) completes a s relative to a set or list of strings, st. +# Put differently, complete() lets you supply a +# partial string, s, and get back those strings in st +# that s is either equal to or a substring of. +# +############################################################################ +# +# Lots of command interfaces allow completion of partial input. +# Complete() simply represents my personal sentiments about how this +# might best be done in Icon. If you strip away the profuse comments +# below, you end up with only about thirty lines of actual source +# code. +# +# I have arranged things so that only that portion of an automaton +# which is needed to complete a given string is actually created and +# stored. Storing automata for later use naturally makes complete() +# eat up more memory. The performance gains can make it worth the +# trouble, though. If, for some reason, there comes a time when it +# is advisable to reclaim the space occupied by complete's static +# structures, you can just call it without arguments. This +# "resets" complete() and forces an immediate garbage collection. +# +# Example code: +# +# commands := ["run","stop","quit","save","load","continue"] +# while line := read(&input) do { +# cmds := list() +# every put(cmds, complete(line, commands)) +# case *cmds of { +# 0 : input_error(line) +# 1 : do_command(cmds[1]) +# default : display_possible_completions(cmds) +# } +# etc... +# +# More Iconish methods might include displaying successive +# alternatives each time the user presses the tab key (this would, +# however, require using the nonportable getch() routine). Another +# method might be to use the first string suspended by complete(). +# +# NOTE: This entire shebang could be replaced with a slightly slower +# and much smaller program suggested to me by Jerry Nowlin and Bob +# Alexander. +# +# procedure terscompl(s, st) +# suspend match(s, p := !st) & p +# end +# +# This program will work fine for lists with just a few members, and +# also for cases where s is fairly large. It will also use much less +# memory. +# +############################################################################ + +procedure complete(s,st) + + local dfstn, c, l, old_chr, chr, newtbl, str, strset + static t + initial t := table() + + # No-arg invocation wipes out static structures & causes an + # immediate garbage collection. + if /s & /st then { + t := table() + collect() # do it NOW + fail + } + type(st) == ("list"|"set") | + stop("error (complete): list or set expected for arg2") + + # Seriously, all that's being done here is that possible states + # are being represented by sets containing possible completions of + # s relative to st. Each time a character is snarfed from s, we + # check to see what strings in st might represent possible + # completions, and store these in yet another set. At some + # point, we either run into a character in s that makes comple- + # tion impossible (fail), or we run out of characters in s (in + # which case we succeed, & suspend each of the possible + # completions). + + # Store any sets we have to create in a static structure for later + # re-use. + /t[st] := table() + + # We'll call the table entry for the current set dfstn. (It really + # does enable us to do things deterministically.) + dfstn := t[st] + + # Snarf one character at a time from s. + every c := !s do { + + # The state we're in is represented by the set of all possible + # completions before c was read. If we haven't yet seen char + # c in this state, run through the current-possible-completion + # set, popping off the first character of each possible + # completion, and then construct a table which uses these + # initial chars as keys, and makes the completions that are + # possible for each of these characters into the values for + # those keys. + if /dfstn[st] then { + + # To get strings that start with the same char together, + # sort the current string set (st). + l := sort(st) + newtbl := table() + old_chr := "" + # Now pop off each member of the sorted string set. Use + # first characters as keys, and then divvy up the full strings + # into sets of strings having the same initial letter. + every str := !l do { + str ? { chr := move(1) | next; str := tab(0) } + if old_chr ~==:= chr then { + strset := set([str]) + insert(newtbl, chr, strset) + } + else insert(strset, str) + } + insert(dfstn, st, newtbl) + } + + # What we've done essentially is to create a table in which + # the keys represent labeled arcs out of the current state, + # and the values represent possible completion sets for those + # paths. What we need to do now is store that table in dfstn + # as the value of the current state-set (i.e. the current + # range of possible completions). Once stored, we can then + # see if there is any arc from the current state (dfstn[st]) + # with the label c (dfstn[st][c]). If so, its value becomes + # the new current state (st), and we cycle around again for + # yet another c. + st := \dfstn[st][c] | fail + if *st = 1 & match(s,!st) + then break + } + + # Eventually we run out of characters in c. The current state + # (i.e. the set of possible completions) can simply be suspended + # one element at a time, with s prefixed to each element. If, for + # instance, st had contained ["hello","help","hear"] at the outset + # and s was equal to "hel", we would now be suspending "hel" || + # !set(["lo","p"]). + suspend s || !st + +end diff --git a/ipl/procs/complex.icn b/ipl/procs/complex.icn new file mode 100644 index 0000000..a3fde1b --- /dev/null +++ b/ipl/procs/complex.icn @@ -0,0 +1,95 @@ +############################################################################ +# +# File: complex.icn +# +# Subject: Procedures to perform complex arithmetic +# +# Author: Ralph E. Griswold +# +# Date: June 21, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# The following procedures perform operations on complex numbers. +# +# complex(r,i) create complex number with real part r and +# imaginary part i +# +# cpxadd(z1, z2) add complex numbers z1 and z2 +# +# cpxdiv(z1, z2) divide complex number z1 by complex number z2 +# +# cpxmul(z1, z2) multiply complex number z1 by complex number z2 +# +# cpxsub(z1, z2) subtract complex number z2 from complex number z1 +# +# cpxstr(z) convert complex number z to string representation +# +# strcpx(s) convert string representation s of complex +# number to complex number +# +############################################################################ + +record complex(rpart, ipart) + +procedure strcpx(s) + + s ? { + ="(" | fail + return complex(numeric(upto('+-')), + 2(move(1), numeric(upto(')')), tab(-1))) + } + +end + +procedure cpxstr(z) + + if z.ipart < 0 then return "(" || z.rpart || z.ipart || "i)" + else return "(" || z.rpart || "+" || z.ipart || "i)" + +end + +procedure cpxadd(z1, z2) + + return complex(z1.rpart + z2.rpart, z1.ipart + z2.ipart) + +end + +procedure cpxsub(z1, z2) + + return complex(z1.rpart - z2.rpart, z1.ipart - z2.ipart) + +end + +procedure cpxmul(z1, z2) + + return complex(z1.rpart * z2.rpart - z1.ipart * z2.ipart, + z1.rpart * z2.ipart + z1.ipart * z2.rpart) + +end + +procedure cpxdiv(z1, z2) + local denom + + denom := z2.rpart ^ 2 + z2.ipart ^ 2 + + return complex((z1.rpart * z2.rpart + z1.ipart * z2.ipart) / denom, + (z1.ipart * z2.rpart - z1.rpart * z2.ipart) / denom) + +end + +procedure cpxconj(z) + + return complex(z.rpart, -z.ipart) + +end + +procedure cpxabs(z) + + return sqrt(z.rpart ^ 2 + z.ipart ^ 2) + +end diff --git a/ipl/procs/conffile.icn b/ipl/procs/conffile.icn new file mode 100644 index 0000000..670aef5 --- /dev/null +++ b/ipl/procs/conffile.icn @@ -0,0 +1,452 @@ +############################################################################# +# +# File: conffile.icn +# +# Subject: Procedures to read initialization directives +# +# Author: David A. Gamey +# +# Date: March 25, 2002 +# +############################################################################# +# +# Thanks to Clint Jeffery for suggesting the Directive wrapper and +# making defining a specification much cleaner looking and easier! +# +############################################################################# +# +# This file is in the public domain. +# +############################################################################# +# +# Description: +# +# At Some point certain procedures become indispensable. Anyone who +# has used 'options' from the Icon program library will probably agree. +# I found a need to be able to quickly, change the format and +# interpretation of a set of configuration and rules files. And so, I +# hope this collection of procedures will become similarly indispensable. +# +# +# Directive( p1, p2, i1, i2 ) : r1 +# +# returns a specification record for a table required by ReadDirectives +# +# p1 is the build procedure used to extract the data from the file. +# The table below describes the build procedures and the default +# minimum and maximum number of arguments for each. If the included +# procedures don't meet your needs then you can easily add your own +# and still use Directive to build the specification. +# +# build procedure minargs maxargs +# +# Directive_table_of_sets 2 - +# Directive_table 2 - +# Directive_value 1 1 +# Directive_set 1 - +# Directive_list 1 - +# < user defined > 1 - +# Directive_exists 0 0 +# Directive_ignore 0 - +# Directive_warning 0 - +# +# p2 is an edit procedure that allows you to preprocess the data or null +# i1 is the minimum number of arguments for this directive, default is 1 +# i2 is the maximum number of arguments for this directive +# +# Run-time Errors: +# - 123 if p1 isn't a procedure +# - 123 if p2 isn't null or a procedure +# - 101 if i1, i2 aren't integers and not ( 0 <= i1 <= i2 ) after defaults +# +# +# ReadDirectives( l1, t1, s1, s2, c1, c2, p1 ) : t2 +# +# returns a table containing parsed directives for the specified file +# +# l1 is a list of file names or open files, each element of l1 is tried +# in turn until a file is opened or an open file is encountered. +# +# For example: [ "my/rules", "/etc/rules", &input ] +# +# t1 is a table of specifications for parsing and handling each directive +# s1 the comment character, default "#" +# s2 the continuation character, default "_" +# c1 the escape character, default "\" +# c2 the cset of whitespace, default ' \b\t\v\f\r' +# p1 stop | an error procedure to be called, fail if null +# +# t2 is a table containing the parsed results keyed by tag +# +# Notes: +# - the special key "*file*" is a list containing the original +# text of input file with interspersed diagnostic messages. +# - the comment, escape, continuation and whitespace characters +# must not overlap (unpredictable) +# - the end of a directive statement will forcibly close an open +# quote (no warning) +# - the end of file will forcibly close a continuation (no warning) +# +# Run-time Errors: +# - 103, 104, 107, 108, 500 +# 500 errors occur if: +# - arguments are too big/small +# - the specification table is improper +# +# Directive file syntax: +# +# - blank lines are ignored +# - all syntactic characters are parameterized +# - everything after a comment character is ignored (discarded) +# - to include a comment character in the directive, +# precede it with an escape +# - to continue a directive, +# place a continue character at the end of the line (before comments) +# - trailing whitespace is NOT ignored in continuations +# - quoted strings are supported, +# - to include a quote within a quoted string, +# precede the enclosed quote with an escape +# +# Usage: +# +# -- Config file, example: -- +# +# # comment line +# +# var1 "This string, w/o quotes, will be in cfgspec[\"var\"]" +# cset1 "abcdefffffffffffff" # type of quotes isn't important +# int1 12345 +# lcase1 "Hello There THIs iS CasE inSENsITive" +# list1 one two three _ # continues +# four five one three zero +# set1 one one one two three 3 'a b c' # one two three 3 'a b c' +# table1 k1 v1 +# table1 k2 v2 +# t/set1 key1 v1 v2 v3 v4 +# t/set1 key2 v5 v6 +# t/set1 key3 "1 2 \#3" # comment +# warn1 this will produce _ +# a warning +# +# -- Coding example: -- +# +# # 1. Define a specification table using Directive. +# # Directive has four fields: +# # - the procedure to handle the tag +# # - an optional edit procedure to preprocess the data +# # - the minimum number of values following the tag, +# # default is dependent on the &null is treated as 0 +# # - the maximum number of values following the tag, +# # &null is treated as unlimited +# # The table's keys are the directives of the configuration file +# # The default specification should be either warning of ignore +# +# cfgspec := table( Directive( Directive_warning ) ) +# cfgspec["var1"] := Directive( Directive_value ) +# cfgspec["cset1"] := Directive( Directive_value, cset ) +# cfgspec["int1"] := Directive( Directive_value, integer ) +# cfgspec["lcase1"] := Directive( Directive_value, map ) +# cfgspec["list1"] := Directive( Directive_list ) +# cfgspec["set1"] := Directive( Directive_set ) +# cfgspec["table1"] := Directive( Directive_table ) +# cfgspec["t/set1"] := Directive( Directive_table_of_sets ) +# +# # 2. Read, parse and build a table based upon the spec and the file +# +# cfg := ReadDirectives( ["my.conf",&input], cfgspec ) +# +# # 3. Process the output +# +# write("Input:\n") +# every write(!cfg["*file*"]) +# write("\nBuilt:\n") +# every k :=key(cfg) do +# if k ~== "*file*" then write(k, " := ",ximage(cfg[k])) +# +# -- Output: -- +# +# Input: +# +# # comment line +# +# var1 "This string, w/o quotes, will be in cfgspec[\"var\"]" +# cset1 "abcdefffffffffffff" # type of quotes isn't important +# int1 12345 +# lcase1 "Hello There THIs iS CasE inSENsITive" +# list1 one two three _ # continues +# four five one three zero +# set1 one one one two three 3 'a b c' # one two three 3 'a b c' +# table1 k1 v1 +# table1 k2 v2 +# t/set1 key1 v1 v2 v3 v4 +# t/set1 key2 v5 v6 +# t/set1 key3 "1 2 \#3" # comment +# warn This will produce a _ +# warning +# -- Directive isn't defined in specification. +# +# Built: +# +# set1 := S1 := set() +# insert(S1,"3") +# insert(S1,"a b c") +# insert(S1,"one") +# insert(S1,"three") +# insert(S1,"two") +# cset1 := 'abcdef' +# t/set1 := T4 := table(&null) +# T4["key1"] := S2 := set() +# insert(S2,"v1") +# insert(S2,"v2") +# insert(S2,"v3") +# insert(S2,"v4") +# T4["key2"] := S3 := set() +# insert(S3,"v5") +# insert(S3,"v6") +# T4["key3"] := S4 := set() +# insert(S4,"1 2 #3") +# list1 := L12 := list(8) +# L12[1] := "one" +# L12[2] := "two" +# L12[3] := "three" +# L12[4] := "four" +# L12[5] := "five" +# L12[6] := "one" +# L12[7] := "three" +# L12[8] := "zero" +# lcase1 := "hello there this is case insensitive" +# int1 := 12345 +# var1 := "This string, w/o quotes, will be in cfgspec[\"var\"]" +# table1 := T3 := table(&null) +# T3["k1"] := "v1" +# T3["k2"] := "v2" +# +############################################################################# + +link lastc + +record _DirectivesSpec_(classproc,editproc,minargs,maxargs) + + +procedure Directive(p,e,mi,mx) #: Wrapper to build directive specification + +if type(p) ~== "procedure" then runerr(123,p) +if type(\e) ~== "procedure" then runerr(123,e) else /e := 1 + +case p of +{ + Directive_table | Directive_table_of_sets: /mi := 2 + Directive_value : { /mi := 1 ; /mx := 1 } + Directive_exists : { /mi := 0 ; /mx := 0 } + default : /mi := 1 +} + +if not ( integer(mi) >= 0 ) then runerr(101,mi) +if \mx & not ( integer(mx) >= mi ) then runerr(101,mx) + +return _DirectivesSpec_(p,e,mi,mx) +end + + +procedure ReadDirectives( #: Builds icon data structures from a config file + fnL,spec,comment,continue,escape,quotes,whitespace,errp) + +local notescape, eof, line, wip, x, y, q, s, d +local sL, sLL, f, fn, fL, action, tag, DirectiveT + +# 1. defaults, type checking and setup + +/comment := "#" +/continue := "_" +/escape := '\\' +/quotes := '\'"' +/whitespace := ' \b\t\v\f\r' + +if not ( comment := string(comment) ) then runerr(103,comment) +if *comment ~= 1 then runerr(500,comment) + +if not ( continue := string(continue) ) then runerr(103,continue) +if *continue ~= 1 then runerr(500,continue) + +if not ( escape := cset(escape) ) then runerr(104,escape) +if *escape ~= 1 then runerr(500,escape) +notescape := ~escape + +if not ( quotes := cset(quotes) ) then runerr(104,quotes) +if *quotes = 0 then runerr(500,quotes) + +if not ( whitespace := cset(whitespace) ) then runerr(104,whitespace) +if *whitespace = 0 then runerr(500,whitespace) + +if type(fnL) ~== "list" then runerr(108,fnL) + +if type(spec) ~== "table" then runerr(124,spec) + +fL := [] # list of original config file +sL := [] # list of lists corresponding to each directive +DirectiveT := table() # results + +# 2. locate (and open) a file + +every fn := !fnL do +{ + if /fn then next + if type(fn) == "file" then break f := fn + if f := open(fn) then break +} +if /f then +{ + write(&errout,"ReadDirectives: no open(able) files in: ",every image(!fnL) ) + \errp() | fail +} + +# 3. input, tokenizing and processing of directives + +while /eof do +{ + + # 3.1 gather complete directive statements + + wip := "" + repeat + { + if not ( line := read(f) ) then eof := line := "" + else + { + put(fL,line) # save original line + line ?:= 2( tab(many(whitespace)), tab(0) ) # discard leading w/s + line ?:= tab(findp(notescape,comment)) # discard comment + line := trim(line,whitespace) + } + wip ||:= line + if wip[-1] == continue then + { + wip := wip[1:-1] + next + } + else break + } + + # 3.2 tokenize directive + + put( sL, sLL := [] ) # start a list of words + wip ? repeat + { + tab( many(whitespace) ) # kill leading white space + if pos(0) then break # deal with trailing whitespace here + + ( q := tab(any(quotes)), + ( x := 1( tab(findp(notescape,q)), =q ) | tab(0) ) + ) | ( x := tab(upto(whitespace) | 0) ) + + y := "" + x ? # strip imbedded escape characters + { + while y ||:= tab(upto(escape)) do move(1) + y ||:= tab(0) + } + put( sLL, y ) # save token + } + + if *sLL = 0 then # remove and skip null lines + pull(sL) & next + + # 3.3 process directive + + action := get(sLL) # peel off the action tag + d := spec[action] + + if /d | /d.classproc then runerr(500,d) + + if *sLL < \d.minargs then put( fL, "-- Fewer arguments than spec allows.") + if *sLL > \d.maxargs then put( fL, "-- More arguments than spec allows.") + + (d.classproc)(fL,DirectiveT,action,sLL,d.editproc) # call build procedure +} + +DirectiveT["*file*"] := fL # save original text +return DirectiveT +end + +# Build support procedures + +procedure Directive_table_of_sets( #: build table of sets: action key value(s) + fileL,DirectiveT,action,argL,editproc) +local tag + +if *argL < 2 then + put(fileL,"-- Too few arguments for (table_of_sets): action key value(s)") +/DirectiveT[action] := table() +/DirectiveT[action][tag := get(argL) ] := set() +while insert(DirectiveT[action][tag],editproc(get(argL)) ) +return +end + + +procedure Directive_table( #: build table: action key value + fileL,DirectiveT,action,argL,editproc) + +if *argL ~= 2 then + put(fileL,"-- Wrong number of arguments for (table): action key value") +/DirectiveT[action] := table() +DirectiveT[action][get(argL)] := editproc(get(argL)) +return +end + + +procedure Directive_set( #: build set: action value(s) + fileL,DirectiveT,action,argL,editproc) + +if *argL < 1 then + put(fileL,"-- Too few arguments for (set): action value(s)") +/DirectiveT[action] := set() +while insert( DirectiveT[action], editproc(get(argL)) ) +return +end + + +procedure Directive_list( #: build list: action value(s) + fileL,DirectiveT,action,argL,editproc) + +if *argL < 1 then + put(fileL,"-- Too few arguments for (list): action value(s)") +/DirectiveT[action] := [] +while put( DirectiveT[action], editproc(get(argL)) ) +return +end + + +procedure Directive_value( #: build value: action value + fileL,DirectiveT,action,argL,editproc) + +if *argL = 0 then + DirectiveT[action] := &null +else + DirectiveT[action] := editproc(get(argL)) +return +end + +procedure Directive_exists( #: build existence flag: action + fileL,DirectiveT,action,argL,editproc) + +if *argL = 0 then + DirectiveT[action] := 1 +else + DirectiveT[action] := editproc(get(argL)) +return +end + + +procedure Directive_ignore( #: quietly ignore any directive + fileL,DirectiveT,action,argL,editproc) + +return +end + + +procedure Directive_warning( #: flag directive with a warning + fileL,DirectiveT,action,argL,editproc) + +put(fileL,"-- Directive isn't defined in specification." ) +return +end diff --git a/ipl/procs/converge.icn b/ipl/procs/converge.icn new file mode 100644 index 0000000..d64a7a7 --- /dev/null +++ b/ipl/procs/converge.icn @@ -0,0 +1,46 @@ +############################################################################ +# +# File: converge.icn +# +# Subject: Procedure to produce continued-fraction convergents +# +# Author: Ralph E. Griswold +# +# Date: June 7, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure produces continued-fraction convergents from a list +# of partial quotients. +# +############################################################################ +# +# Links: rational +# +############################################################################ + +link rational + +procedure converge(seq) #: continued-fraction convergents + local prev_p, prev_q, p, q, t + + seq := copy(seq) + + prev_p := [0, 1] + prev_q := [1, 0] + + while t := get(seq) do { + p := t * prev_p[2] + prev_p[1] + q := t * prev_q[2] + prev_q[1] + suspend rational(p, q, 1) + prev_p[1] := prev_p[2] + prev_p[2] := p + prev_q[1] := prev_q[2] + prev_q[2] := q + } + +end diff --git a/ipl/procs/convert.icn b/ipl/procs/convert.icn new file mode 100644 index 0000000..6574c35 --- /dev/null +++ b/ipl/procs/convert.icn @@ -0,0 +1,68 @@ +############################################################################ +# +# File: convert.icn +# +# Subject: Procedures for various conversions +# +# Author: Ralph E. Griswold +# +# Date: March 19, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# exbase10(i, j) converts base-10 integer i to base j. +# +# inbase10(s, i) convert base-i integer s to base 10. +# +# radcon(s, i, j) convert base-i integer s to base j. +# +# There are several other procedures related to conversion that are +# not yet part of this module. +# +############################################################################ + +procedure exbase10(i, j) #: convert base 10 to arbitrary base + local s, d, sign + static digits + + initial digits := &digits || &lcase || &ucase + + if not(2 <= j <= *digits) then stop("*** base out of range") + + if i = 0 then return 0 + + if i < 0 then { + sign := "-" + i := -i + } + else sign := "" + s := "" + while i > 0 do { + d := i % j + if d > 9 then d := digits[d + 1] + s := d || s + i /:= j + } + + return sign || s + +end + +procedure inbase10(s, i) #: convert arbitrary base to base 10 + + if i > 36 then stop("*** base too large for inbase10()") + + if s[1] == "-" then return "-" || integer(i || "r" || s[2:0]) + else return integer(i || "r" || s) + +end + +procedure radcon(s, i, j) #: convert between bases + + return exbase10(inbase10(s,i),j) + +end diff --git a/ipl/procs/core.icn b/ipl/procs/core.icn new file mode 100644 index 0000000..14c2888 --- /dev/null +++ b/ipl/procs/core.icn @@ -0,0 +1,40 @@ +############################################################################ +# +# File: core.icn +# +# Subject: Procedures for general application +# +# Author: Gregg M. Townsend +# +# Date: August 4, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Links to core modules of the basic part of the library, as defined +# in the Icon Language book (3/e, p.179) and Graphics book (p.47). +# +############################################################################ +# +# Links: convert, datetime, factors, io, lists, math, numbers, +# random, records, scan, sets, sort, strings, tables +# +############################################################################ + +link convert +link datetime +link factors +link io +link lists +link math +link numbers +link random +link records +link scan +link sets +link sort +link strings +link tables diff --git a/ipl/procs/created.icn b/ipl/procs/created.icn new file mode 100644 index 0000000..d4c4685 --- /dev/null +++ b/ipl/procs/created.icn @@ -0,0 +1,33 @@ +############################################################################ +# +# File: created.icn +# +# Subject: Procedure to determine number of structures created +# +# Author: Ralph E. Griswold +# +# Date: March 25, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program returns the number of structures of a given type that have +# been created. +# +############################################################################ +# +# Links: serial +# +############################################################################ + +link serial + +procedure created(kind) #: number of structures created + + return serial(proc(kind)()) + fail + +end diff --git a/ipl/procs/currency.icn b/ipl/procs/currency.icn new file mode 100644 index 0000000..18f3d8c --- /dev/null +++ b/ipl/procs/currency.icn @@ -0,0 +1,51 @@ +############################################################################ +# +# File: currency.icn +# +# Subject: Procedures for formatting currency +# +# Author: Robert J. Alexander +# +# Date: September 21, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# currency() -- Formats "amount" in standard American currency format. +# "amount" can be a real, integer, or numeric string. "width" is the +# output field width, in which the amount is right adjusted. The +# returned string will be longer than "width" if necessary to preserve +# significance. "minus" is the character string to be used for +# negative amounts (default "-"), and is placed to the right of the +# amount. +# +############################################################################ + +procedure currency(amount,width,minus,decPlaces,minDollarDigits, + currencySign,decimalPoint,comma) + local sign,p + amount := real(amount) | fail + /width := 0 + /minus := "-" + /decPlaces := 2 + /minDollarDigits := 1 + /currencySign := "$" + /decimalPoint := "." + /comma := "," + if amount < 0.0 then { + sign := minus + amount := -amount + } + else sign := repl(" ",*minus) + amount := (integer(amount * 10.0 ^ (decPlaces + 1)) + 5)[1:-1] + amount := right(amount,*amount < decPlaces + minDollarDigits,"0") + p := *amount - decPlaces + 1 + amount[p:p] := decimalPoint + while (p -:= 3) > 1 do amount[p:p] := comma + amount := currencySign || amount || sign + amount := right(amount,*amount < width) + return amount +end diff --git a/ipl/procs/curves.icn b/ipl/procs/curves.icn new file mode 100644 index 0000000..a3a3a2a --- /dev/null +++ b/ipl/procs/curves.icn @@ -0,0 +1,520 @@ +############################################################################ +# +# File: curves.icn +# +# Subject: Procedures to generate points on plain curves +# +# Author: Ralph E. Griswold +# +# Date: March 25, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This file links procedure files that generate traces of points on various +# plain curves. +# +# The first two parameters determine the defining position of the +# curve: +# +# x x coordinate +# y y coordinate +# +# The meaning of "definition position" depends on the curve. In some +# cases it is the position at which plotting starts. In others, it +# is a "center" for the curve. +# +# The next arguments vary and generally refer to parameters of the +# curve. There is no practical way to describe these here. If they +# are not obvious, the best reference is +# +# A Catalog of Special Plane Curves, J. Dennis Lawrence, +# Dover Publications, Inc., New York, 1972. +# +# This book, which is in print at the time of this writing, is a +# marvelous source of information about plane curves and is inexpensive +# as well. +# +# The trailing parameters give the number of steps and the end points +# (generally in angles) of the curves: +# +# steps number of points, default varies +# lo beginning of plotting range, default varies +# hi end of plotting range, default varies +# +# Because of floating-point roundoff, the number of steps +# may not be exactly the number specified. +# +# Note: Some of the curves may be "upside down" when plotted on +# coordinate systems in which the y axis increases in a downward direction. +# +# Caution: Some of these procedures generate very large values +# in portions of their ranges. These may cause run-time errors when +# used in versions of Icon prior to 8.10. One work-around is to +# turn on error conversion in such cases. +# +# Warning: The procedures that follow have not been tested thoroughly. +# Corrections and additions are most welcome. +# +# These procedures are, in fact, probably most useful for the parametric +# equations they contain. +# +############################################################################ +# +# Links: gobject, math, step +# +############################################################################ + +link gobject +link math +link step + +procedure bullet_nose(x, y, a, b, steps, lo, hi) + local incr, theta + + /steps := 300 + lo := dtor(\lo) | -&pi + hi := dtor(\hi) | &pi + incr := (hi - lo) / steps + + every theta := step(lo, hi, incr) do + suspend Point( + x + a * cos(theta), + y + b * tan(&pi / 2 - theta), + 0 + ) + +end + +procedure cardioid(x, y, a, steps, lo, hi) + local incr, theta, fact + + /steps := 300 + lo := dtor(\lo) | -&pi + hi := dtor(\hi) | &pi + incr := (hi - lo) / steps + + every theta := step(lo, hi, incr) do { + fact := 2 * a * (1 + cos(theta)) + suspend Point( + x + cos(theta) * fact, + y + sin(theta) * fact, + 0 + ) + } + +end + +procedure cissoid_diocles(x, y, a, steps, lo, hi) + local incr, theta, radius + + /steps := 300 + lo := dtor(\lo) | (-2 * &pi) + hi := dtor(\hi) | (2 * &pi) + incr := (hi - lo) / steps + + every theta := step(lo, hi, incr) do { + radius := a * sin(theta) * cos(theta) + suspend Point( + x + radius * cos(theta), + y + radius * sin(theta), + 0 + ) + } + +end + +procedure cross_curve(x, y, a, b, steps, lo, hi) + local incr, theta + + /steps := 300 + lo := dtor(\lo) | -&pi + hi := dtor(\hi) | &pi + incr := (hi - lo) / steps + + every theta := step(lo, hi, incr) do + suspend Point( + x + a / cos(theta), + y + b / sin(theta), + 0 + ) + +end + +procedure cycloid(x, y, a, b, steps, lo, hi) + local incr, theta + + /steps := 100 + lo := dtor(\lo) | 0 + hi := dtor(\hi) | (8 * &pi) + incr := (hi - lo) / steps + + every theta := step(lo, hi, incr) do + suspend Point( + x + a * theta - b * sin(theta), + y + a - b * cos(theta), + 0 + ) + +end + +procedure deltoid(x, y, a, steps, lo, hi) + local incr, theta + + /steps := 300 + lo := dtor(\lo) | -&pi + hi := dtor(\hi) | &pi + incr := (hi - lo) / steps + + every theta := step(lo, hi, incr) do + suspend Point( + x + a * (2 * cos(theta) + cos(2 * theta)), + y + a * (2 * sin(theta) - sin(2 * theta)), + 0 + ) + +end + +procedure ellipse(x, y, a, b, steps, lo, hi) + local incr, theta + + /steps := 300 + lo := dtor(\lo) | -&pi + hi := dtor(\hi) | &pi + incr := (hi - lo) / steps + + every theta := step(lo, hi, incr) do + suspend Point( + x + a * cos(theta), + y + b * sin(theta), + 0 + ) + +end + +procedure ellipse_evolute(x, y, a, b, steps, lo, hi) + local incr, theta + + /steps := 300 + lo := dtor(\lo) | -&pi + hi := dtor(\hi) | &pi + incr := (hi - lo) / steps + + every theta := step(lo, hi, incr) do + suspend Point( + x + a * cos(theta) ^ 3, + y + b * sin(theta) ^ 3, + 0 + ) + +end + +procedure epitrochoid(x, y, a, b, h, steps, lo, hi) + local incr, theta, sum, fact + + /steps := 300 + lo := dtor(\lo) | -&pi + hi := dtor(\hi) | &pi + incr := (hi - lo) / steps + + sum := a + b + fact := sum / b + + every theta := step(lo, hi, incr) do + suspend Point( + x + sum * cos(theta) - h * cos(fact * theta), + y + sum * sin(theta) - h * sin(fact * theta), + 0 + ) + +end + +procedure folium(x, y, a, b, steps, lo, hi) + local incr, theta, radius + + /steps := 300 + lo := dtor(\lo) | -&pi + hi := dtor(\hi) | &pi + incr := (hi - lo) / steps + + every theta := step(lo, hi, incr) do { + radius := (3 * a * sin(theta) * cos(theta)) / + (sin(theta) ^ 2 + cos(theta) ^ 2) + suspend Point( + x + radius * cos(theta), + y + radius * sin(theta), + 0 + ) + } + +end + +procedure hippopede(x, y, a, b, steps, lo, hi) + local incr, theta, mul + + /steps := 300 + lo := dtor(\lo) | -&pi + hi := dtor(\hi) | &pi + incr := (hi - lo) / steps + + every theta := step(lo, hi, incr) do { + mul := a * b - b ^ 2 * sin(theta) ^ 2 + if mul < 0 then next + mul := 2 * sqrt(mul) + suspend Point( + x + mul * cos(theta), + y + mul *sin(theta), + 0 + ) + } + +end + +procedure kampyle_exodus(x, y, a, b, steps, lo, hi) + local incr, theta, fact + + /steps := 300 + lo := dtor(\lo) | (-&pi / 2) + hi := dtor(\hi) | (3 * &pi / 2) + incr := (hi - lo) / steps + + every theta := step(lo, hi, incr) do { + fact := a / cos(theta) + suspend Point( + x + fact, + y + fact * tan(theta), + 0 + ) + } + +end + +procedure kappa(x, y, a, b, steps, lo, hi) + local incr, theta, fact + + /steps := 300 + lo := dtor(\lo) | 0 + hi := dtor(\hi) | (2 * &pi) + incr := (hi - lo) / steps + + every theta := step(lo, hi, incr) do { + fact := a * cos(theta) + suspend Point( + x + fact / (0 ~= tan(theta)), + y + fact, + 0 + ) + } + +end + +procedure lemniscate_bernoulli(x, y, a, steps, lo, hi) + local incr, theta, fact + + /steps := 300 + lo := dtor(\lo) | -&pi + hi := dtor(\hi) | &pi + incr := (hi - lo) / steps + + every theta := step(lo, hi, incr) do { + fact := a * cos(theta) / (1 + sin(theta) ^ 2) + suspend Point( + x + fact, + y + fact * sin(theta), + 0 + ) + } + +end + +procedure lemniscate_gerono(x, y, a, b, steps, lo, hi) + local incr, theta, fact + + /steps := 300 + lo := dtor(\lo) | -&pi + hi := dtor(\hi) | &pi + incr := (hi - lo) / steps + + every theta := step(lo, hi, incr) do { + fact := a * cos(theta) + suspend Point( + x + fact, + y + sin(theta) * fact, + 0 + ) + } + +end + +procedure limacon_pascal(x, y, a, b, steps, lo, hi) + local incr, theta, fact + + /steps := 300 + lo := dtor(\lo) | -&pi + hi := dtor(\hi) | &pi + incr := (hi - lo) / steps + + every theta := step(lo, hi, incr) do { + fact := b + 2 * a * cos(theta) + suspend Point( + x + fact * cos(theta), + y + fact * sin(theta), + 0 + ) + } + +end + +procedure line(x, y, x1, y1, steps) + local xincr, yincr + + /steps := 100 + + xincr := (x1 - x) / (steps - 1) + yincr := (y1 - y) / (steps - 1) + + every 1 to steps do { + suspend Point(x, y, 0) + x +:= xincr + y +:= yincr + } + +end + +procedure lissajous(x, y, a, b, r, delta, steps, lo, hi) + local incr, theta + + /steps := 300 + lo := dtor(\lo) | 0 + hi := dtor(\hi) | (16 * &pi) + incr := (hi - lo) / steps + + r := dtor(r) + + every theta := step(lo, hi, incr) do + suspend Point( + x + a * sin(r * theta + delta), + y + b * sin(theta), + 0 + ) + +end + +procedure nephroid(x, y, a, steps, lo, hi) + local incr, theta + + /steps := 300 + lo := dtor(\lo) | -&pi + hi := dtor(\hi) | &pi + incr := (hi - lo) / steps + + every theta := step(lo, hi, incr) do + suspend Point( + x + a * (3 * cos(theta) - cos(3 * theta)), + y + a * (3 * sin(theta) - sin(3 * theta)), + 0 + ) + +end + +# Needs to be checked out + +procedure parabola(x, y, a, steps, lo, hi) + local incr, theta, denom, radius + + /steps := 300 + lo := dtor(\lo) | -&pi + hi := dtor(\hi) | &pi + incr := (hi - lo) / steps + + every theta := step(lo, hi, incr) do { + denom := 1 - cos(theta) + if denom = 0 then next + radius := 2 * a / denom + suspend Point( + radius * cos(theta), + radius * sin(theta), + 0 + ) + } + +end + +procedure piriform(x, y, a, b, steps, lo, hi) + local incr, theta, fact + + /steps := 300 + lo := dtor(\lo) | (-&pi / 2) + hi := dtor(\hi) | (3 * &pi / 2) + incr := (hi - lo) / steps + + every theta := step(lo, hi, incr) do { + fact := 1 + sin(theta) + suspend Point( + x + a * fact, + y + b * cos(theta) * fact, + 0 + ) + } + +end + +procedure trisectrix_catalan(x, y, a, steps, lo, hi) + local incr, theta, radius + + /steps := 300 + lo := dtor(\lo) | (-2 * &pi) + hi := dtor(\hi) | (2 * &pi) + incr := (hi - lo) / steps + + every theta := step(lo, hi, incr) do { + radius := a / cos(theta / 3) ^ 3 + suspend Point( + x + radius * cos(theta), + y + radius * sin(theta), + 0 + ) + } + +end + +procedure trisectrix_maclaurin(x, y, a, b, steps, lo, hi) + local incr, theta, fact + + /steps := 300 + lo := dtor(\lo) | (-&pi / 2) + hi := dtor(\hi) | (&pi / 2) + incr := (hi - lo) / steps + + every theta := step(lo, hi, incr) do { + fact := a * (1 - 4 * cos(theta) ^ 2) + suspend Point( + x + fact, + y + fact * tan(theta), + 0 + ) + } + +end + +procedure witch_agnesi(x, y, a, steps, lo, hi) + local incr, theta, fact + + /steps := 300 + lo := dtor(\lo) | (-&pi /2) + hi := dtor(\hi) | (&pi / 2) + incr := (hi - lo) / steps + + fact := 2 * a + + every theta := step(lo, hi, incr) do + suspend Point( + x + fact * tan(theta), + y - fact * cos(theta) ^ 2, + 0 + ) + +end diff --git a/ipl/procs/datefns.icn b/ipl/procs/datefns.icn new file mode 100644 index 0000000..2fe8b79 --- /dev/null +++ b/ipl/procs/datefns.icn @@ -0,0 +1,196 @@ +############################################################################ +# +# File: datefns.icn +# +# Subject: Procedure for dates +# +# Author: Charles Hethcoat +# +# Date: August 14, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# datefns.icn - a collection of date functions +# +# Adaptor: Charles L Hethcoat III +# June 12, 1995 +# Taken from various sources as attributed below. +# +# All date and calendar functions use the "date_rec" structure defined +# below. +# +# Note: I adapted the procedures "julian" and "unjulian" sometime in 1994 +# from "Numerical Recipes in C." Some time later I discovered them +# (under slightly different names) in Version 9 of the Icon Library +# (Ralph Griswold, author). I am including mine for what they are worth. +# That'll teach me to wait! +# +############################################################################ + +record date_rec(year, month, day, yearday, monthname, dayname) + +global monthlist # Maps month numbers into month names +global monthtbl # Maps month names into numbers 1-12 +global dow # Maps 1-7 into Sunday-Saturday +global cum_days # Cum. day counts for month end, leap & non-leap yrs. + +# initdate - call to initialize the global data before using other fns. +# See "The C Programming Language," by Kernighan and Richie (Wylie, +# 1978) + +procedure initdate() + monthlist := + ["January", "February", "March", "April", + "May", "June", "July", "August", + "September", "October", "November", "December"] + + monthtbl := table() + monthtbl["January"] := 1 + monthtbl["February"] := 2 + monthtbl["March"] := 3 + monthtbl["April"] := 4 + monthtbl["May"] := 5 + monthtbl["June"] := 6 + monthtbl["July"] := 7 + monthtbl["August"] := 8 + monthtbl["September"] := 9 + monthtbl["October"] := 10 + monthtbl["November"] := 11 + monthtbl["December"] := 12 + + dow := + ["Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", + "Friday", "Saturday"] + cum_days := [ + [0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365], + [0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366] + ] + return +end + +# today - obtain computationally-useful values for today's date +procedure today() + local junk, datestruct + + datestruct := date_rec() + &dateline ? { # &dateline is in a fixed format: + junk := tab(upto(&letters)) + datestruct.dayname := tab(many(&letters)) + junk := tab(upto(&letters)) + datestruct.monthname := tab(many(&letters)) + junk := tab(upto(&digits)) + datestruct.day := tab(many(&digits)) + junk := tab(upto(&digits)) + datestruct.year := tab(many(&digits)) + } + + datestruct.month := monthtbl[datestruct.monthname] + datestruct.yearday := doy(datestruct.year, datestruct.month, datestruct.day) + return datestruct +end + +# The next two routines have been adapted from "Numerical Recipes in C," +# by Press, Flannery, Teukolsky, and Vetterling (Cambridge, 1988). The +# following quote is from page 10: + +# Astronomers number each 24-hour period, starting and ending at noon, +# with a unique integer, the Julian Day Number. Julian Day Zero was +# a very long time ago; a convenient reference point is that Julian +# Day 2440000 began at noon of May 23, 1968. If you know the Julian +# Day Number that began at noon of a given calendar date, then the day +# of the week of that date is obtained by adding 1 and taking the result +# modulo base 7; a zero answer corresponds to Sunday, 1 to Monday, ..., +# 6 to Saturday. + +# The C code presented in that book heavily uses the automatic conversion +# of real (floating point) numbers to integers by truncation. Since Icon +# doesn't do this, explicit type conversions are required. + +# julian - convert a date_rec to a Julian day number +procedure julian(date) + + local jul + local ja, jy, jm, z1, z2 + + if date.year = 0 then + fail + if date.year < 0 then + date.year +:= 1 + if date.month > 2 then { + jy := date.year + jm := date.month + 1 + } else { + jy := date.year - 1 + jm := date.month + 13 + } + + z1 := real(integer(365.25*jy)) + z2 := real(integer(30.6001*jm)) + jul := integer(z1 + z2 + date.day + 1720995) + if date.day + 31*(date.month + 12*date.year) >= 588829 then { + ja := integer(0.01*jy) + jul +:= 2 - ja + integer(0.25*ja) + } + return jul + +end + +# unjulian - produce a date from the Julian day number +procedure unjulian(julianday) + + local ja, jalpha, jb, jc, jd, je # integers all + local datestruct + + datestruct := date_rec() + if julianday >= 2299161 then { + jalpha := integer((real(julianday - 1867216) - 0.25)/36524.25) + ja := julianday + 1 + jalpha - integer(0.25*jalpha) + } else + ja := julianday + jb := ja + 1524 + jc := integer(6680.0 + (real(jb - 2439870) - 122.1)/365.25) + jd := 365*jc + integer(0.25*jc) + je := integer((jb - jd)/30.6001) + datestruct.day := jb - jd - integer(30.6001*je) + datestruct.month := je - 1 + if datestruct.month > 12 then + datestruct.month -:= 12 + datestruct.year := jc - 4715 + if datestruct.month > 2 then + datestruct.year -:= 1 + if datestruct.year <= 0 then + datestruct.year -:= 1 + # Get the day number in the year: + datestruct.yearday := doy(datestruct.year, datestruct.month, datestruct.day) + # Get the name of the month: + datestruct.monthname := monthlist[datestruct.month] + # Calculate the day of the week: + datestruct.dayname := dow[(julianday + 1) % 7 + 1] + return datestruct + +end + +# doy - return day-of-year from (year, month, day) +# Adapted from K&R +procedure doy(year, month, day) + local leap, y, m, d + y := integer(year) + m := integer(month) + d := integer(day) + leap := + if (y % 4 = 0 & y % 100 ~= 0) | y % 400 = 0 then + 2 # leap year + else + 1 # non-leap year + return cum_days[leap][m] + d +end + +# wrdate - write out a basic date string with a leadin string +procedure wrdate(leadin, date) + write(leadin, " ", date.year, " ", date.monthname, " ", date.day) +end + diff --git a/ipl/procs/datetime.icn b/ipl/procs/datetime.icn new file mode 100644 index 0000000..b57e49a --- /dev/null +++ b/ipl/procs/datetime.icn @@ -0,0 +1,607 @@ +############################################################################ +# +# File: datetime.icn +# +# Subject: Procedures for date and time operations +# +# Author: Robert J. Alexander and Ralph E. Griswold +# +# Date: August 9, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Notes: +# - the default value for function parameters named +# "hoursFromGmt" is the value of global variable +# "HoursFromGmt" if nonnull, or environment variable +# "HoursFromGmt" if set, or 0. +# - The base year from which the "seconds" representation +# of a date is calculated is by default 1970 (the ad hoc +# standard used by both Unix and MS-Windows), but can be +# changed by either setting the global variable +# "DateBaseYear" or environment variable "DateBaseYear". +# - There are some procedures not mentioned in this summary +# that are useful: DateRecToSec(), SecToDateRec(). See the +# source code for details. +# +# ClockToSec(seconds) +# converts a time in the format of &clock to seconds past +# midnight. +# +# DateLineToSec(dateline,hoursFromGmt) +# converts a date in &dateline format to seconds since start of +# dateBaseYear. +# +# DateToSec(date,hoursFromGmt) +# converts a date string in Icon &date format (yyyy/mm/dd) +# to seconds past DateBaseYear. +# +# SecToClock(seconds) +# converts seconds past midnight to a string in the format of +# &clock. +# +# SecToDate(seconds,hoursFromGmt) +# converts seconds past DateBaseYear to a string in Icon +# &date format (yyyy/mm/dd). +# +# SecToDateLine(seconds,hoursFromGmt) +# produces a date in the same format as Icon's &dateline. +# +# SecToUnixDate(seconds,hoursFromGmt) +# returns a date and time in typical UNIX format: +# Jan 14 10:24 1991. +# +# IsLeapYear(year) +# succeeds if year is a leap year, otherwise fails. +# +# calendat(j) +# returns a record with the month, day, and year corresponding +# to the Julian Date Number j. +# +# date() natural date in English. +# +# dayoweek(day, month, year) +# produces the day of the week for the given date. +# Note carefully the parameter order. +# +# full13th(year1, year2) +# generates records giving the days on which a full moon occurs +# on Friday the 13th in the range from year1 though year2. +# +# julian(m, d, y) +# returns the Julian Day Number for the specified +# month, day, and year. +# +# pom(n, phase) +# returns record with the Julian Day number of fractional +# part of the day for which the nth such phase since +# January, 1900. Phases are encoded as: +# +# 0 - new moon +# 1 - first quarter +# 2 - full moon +# 3 - last quarter# +# +# GMT is assumed. +# +# saytime() +# computes the time in natural English. If an argument is +# supplied it is used as a test value to check the operation +# the program. +# +# walltime() +# produces the number of seconds since midnight. Beware +# wrap-around when used in programs that span midnight. +# +############################################################################ +# +# See also: datefns.icn +# +############################################################################ +# +# Acknowledgement: Some of these procedures are based on an algorithm +# given in "Numerical Recipes; The Art of Scientific Computing"; +# William H. Press, Brian P. Flannery, Saul A. Teukolsky, and William +# T. Vetterling;# Cambridge University Press, 1986. +# +############################################################################ + +record date1(month, day, year) +record date2(month, year, fraction) +record jdate(number, fraction) +record DateRec(year,month,day,hour,min,sec,weekday) + +global Months,Days,DateBaseYear,HoursFromGmt + +procedure ClockToSec(seconds) #: convert &date to seconds +# +# Converts a time in the format of &clock to seconds past midnight. +# + seconds ? return ( + (1(tab(many(&digits)),move(1)) * 60 + + 1(tab(many(&digits)),move(1) | &null)) * 60 + + (tab(many(&digits)) | 0) + ) +end + +procedure DateInit() +# +# Initialize the date globals -- done automatically by calls to date +# procedures. +# + initial { + Months := ["January","February","March","April","May","June", + "July","August","September","October","November","December"] + Days := ["Sunday","Monday","Tuesday","Wednesday","Thursday", + "Friday","Saturday"] + /DateBaseYear := integer(getenv("DateBaseYear")) | 1970 + /HoursFromGmt := integer(getenv("HoursFromGmt")) | 0 + } + return +end + + +procedure DateLineToSec(dateline,hoursFromGmt) #: convert &dateline to seconds +# +# Converts a date in long form to seconds since start of DateBaseYear. +# + local day,halfday,hour,min,month,sec,year + static months + initial { + DateInit() + months := table() + months["jan"] := 1 + months["feb"] := 2 + months["mar"] := 3 + months["apr"] := 4 + months["may"] := 5 + months["jun"] := 6 + months["jul"] := 7 + months["aug"] := 8 + months["sep"] := 9 + months["oct"] := 10 + months["nov"] := 11 + months["dec"] := 12 + } + map(dateline) ? { + tab(many(' \t')) + =("sun" | "mon" | "tue" | "wed" | "thu" | "fri" | "sat") & + tab(many(&letters)) | &null & tab(many(' \t,')) | &null + month := 1(tab(many(&letters)),tab(many(' \t')) | &null) + day <- integer(1(tab(many(&digits)),tab(many(' \t,')) | &null)) | &null & + year <- integer(1(tab(many(&digits)),tab(many(' \t')) | &null)) | &null & + (hour <- integer(tab(many(&digits))) & + ((=":" & min <- integer(tab(many(&digits)))) & + ((=":" & sec <- integer(tab(many(&digits)))) | &null) | &null) & + tab(many(' \t')) | &null & halfday := =("am" | "pm") | &null & + tab(many(' \t')) | &null) | &null & pos(0) + } + \month := \months[month[1+:3]] | fail + if not /(halfday | hour) then { + if hour = 12 then hour := 0 + if halfday == "pm" then + hour +:= 12 + } + return DateRecToSec(DateRec(year,month,day,hour,min,sec),hoursFromGmt) +end + +procedure DateRecToSec(dateRec,hoursFromGmt) +# +# Converts a DateRec to seconds since start of DateBaseYear. +# + local day,hour,min,month,sec,secs,year,yr + static days + initial { + DateInit() + days := [ + 0, + 2678400, + 5097600, + 7776000, + 10368000, + 13046400, + 15638400, + 18316800, + 20995200, + 23587200, + 26265600, + 28857600 + ] + } + /hoursFromGmt := HoursFromGmt + hoursFromGmt := integer(hoursFromGmt) | runerr(101,hoursFromGmt) + year := \dateRec.year | +&date[1+:4] + month := \dateRec.month | +&date[6+:2] + day := \dateRec.day | +&date[9+:2] + hour := \dateRec.hour | 0 + min := \dateRec.min | 0 + sec := \dateRec.sec | 0 + secs := 0 + every yr := DateBaseYear to year - 1 do { + secs +:= if IsLeapYear(yr) then 31622400 else 31536000 + } + if month > 2 & IsLeapYear(year) then secs +:= 86400 + return secs + days[month] + (day - 1) * 86400 + + (hour - hoursFromGmt) * 3600 + min * 60 + sec +end + +procedure DateToSec(date,hoursFromGmt) #: convert &date to seconds +# +# Converts a date in Icon &date format (yyyy/mm/dd) do seconds +# past DateBaseYear. +# + date ? return DateRecToSec(DateRec(+1(tab(find("/")),move(1)), + +1(tab(find("/")),move(1)),+tab(0)),hoursFromGmt) +end + +procedure SecToClock(seconds) #: convert seconds to &clock +# +# Converts seconds past midnight to a string in the format of &clock. +# + local sec + sec := seconds % 60 + seconds /:= 60 + return right(seconds / 60,2,"0") || ":" || right(seconds % 60,2,"0") || + ":" || right(sec,2,"0") +end + +procedure SecToDate(seconds,hoursFromGmt) #: convert seconds to &date +# +# Converts seconds past DateBaseYear to a &date in Icon date format +# (yyyy,mm,dd). +# + local r + r := SecToDateRec(seconds,hoursFromGmt) + return right(r.year,4,"0") || "/" || right(r.month,2,"0") || "/" || + right(r.day,2,"0") +end + +procedure SecToDateLine(seconds,hoursFromGmt) #: convert seconds to &dateline +# +# Produces a date in the same format as Icon's &dateline. +# + local d,hour,halfday + d := SecToDateRec(seconds,hoursFromGmt) + if (hour := d.hour) < 12 then { + halfday := "am" + } + else { + halfday := "pm" + hour -:= 12 + } + if hour = 0 then hour := 12 + return Days[d.weekday] || ", " || Months[d.month] || " " || d.day || + ", " || d.year || " " || hour || ":" || right(d.min,2,"0") || " " || + halfday +end + +procedure SecToDateRec(seconds,hoursFromGmt) +# +# Produces a date record computed from the seconds since the start of +# DateBaseYear. +# + local day,hour,min,month,secs,weekday,year + initial DateInit() + seconds := integer(seconds) | runerr(101,seconds) + /hoursFromGmt := HoursFromGmt + hoursFromGmt := integer(hoursFromGmt) | runerr(101,hoursFromGmt) + seconds +:= hoursFromGmt * 3600 + weekday := (seconds / 86400 % 7 + 4) % 7 + 1 + year := DateBaseYear + repeat { + secs := if IsLeapYear(year) then 31622400 else 31536000 + if seconds < secs then break + year +:= 1 + seconds -:= secs + } + month := 1 + every secs := + 2678400 | + (if IsLeapYear(year) then 2505600 else 2419200) | + 2678400 | + 2592000 | + 2678400 | + 2592000 | + 2678400 | + 2678400 | + 2592000 | + 2678400 | + 2592000 | + 2678400 do { + if seconds < secs then break + month +:= 1 + seconds -:= secs + } + day := seconds / 86400 + 1 + seconds %:= 86400 + hour := seconds / 3600 + seconds %:= 3600 + min := seconds / 60 + seconds %:= 60 + return DateRec(year,month,day,hour,min,seconds,weekday) +end + +procedure SecToUnixDate(seconds,hoursFromGmt) #: convert seconds to UNIX time +# +# Returns a date and time in UNIX format: Jan 14 10:24 1991 +# + local d + d := SecToDateRec(seconds,hoursFromGmt) + return Months[d.month][1+:3] || " " || d.day || " " || + d.hour || ":" || right(d.min,2,"0") || " " || d.year +end + +procedure IsLeapYear(year) #: determine if year is leap + # + # Fails unless year is a leap year. + # + return year % 4 = 0 & (year % 100 ~= 0 | year % 400 = 0) & &null +end + +procedure calendat(julian) #: Julian date + local ja, jalpha, jb, jc, jd, je, gregorian + local month, day, year + + gregorian := 2299161 + + if julian >= gregorian then { + jalpha := integer(((julian - 1867216) - 0.25) / 36524.25) + ja := julian + 1 + jalpha - integer(0.25 * jalpha) + } + else ja := julian + + jb := ja + 1524 + jc := integer(6680.0 + ((jb - 2439870) - 122.1) / 365.25) + jd := 365 * jc + integer(0.25 * jc) + je := integer((jb - jd) / 30.6001) + day := jb - jd - integer(30.6001 * je) + month := je - 1 + if month > 12 then month -:= 12 + year := jc - 4715 + if month > 2 then year -:= 1 + if year <= 0 then year -:= 1 + + return date1(month, day, year) + +end + +procedure date() #: date in natural English + + &dateline ? { + tab(find(", ") + 2) + return tab(find(" ")) + } + +end + +procedure dayoweek(day, month, year) #: day of the week +# +# The method used was adapted from a Web page by Mark Dettinger. +# URL as of 7 August 2000 was: +# http://www.informatik.uni-ulm.de/pm/mitarbeiter/mark/day_of_week.html +# + static d_code, c_code, m_code, ml_code, y, C, M, Y + + initial { + d_code := ["Saturday", "Sunday", "Monday", "Tuesday", "Wednesday", + "Thursday", "Friday"] + + c_code := table() + c_code[16] := c_code[20] := 0 + c_code[17] := c_code[21] := 6 + c_code[18] := c_code[22] := 4 + c_code[19] := c_code[23] := 2 + + m_code := table() + m_code[1] := m_code["January"] := 1 + m_code[2] := m_code["February"] := 4 + m_code[3] := m_code["March"] := 4 + m_code[4] := m_code["April"] := 0 + m_code[5] := m_code["May"] := 2 + m_code[6] := m_code["June"] := 5 + m_code[7] := m_code["July"] := 0 + m_code[8] := m_code["August"] := 3 + m_code[9] := m_code["September"] := 6 + m_code[10] := m_code["October"] := 1 + m_code[11] := m_code["November"] := 4 + m_code[12] := m_code["December"] := 6 + + ml_code := copy(m_code) + ml_code[1] := ml_code["January"] := 0 + ml_code[2] := ml_code["February"] := 3 + } + + # This can be fixed to go back to October 15, 1582. + + if year < 1600 then stop("*** can't compute day of week that far back") + + # This can be fixed to go indefinitely far into the future; the day of + # of the week repeats every 400 years. + + if year > 2299 then stop("*** can't compute day of week that far ahead") + + C := c_code[(year / 100) + 1] + y := year % 100 + Y := (y / 12) + (y % 12) + ((y % 12) / 4) + month := integer(month) + M := if (year % 4) = 0 then ml_code[month] else m_code[month] + + return d_code[(C + Y + M + day) % 7 + 1] + +end + +procedure full13th(year1, year2) #: full moons on Friday 13ths + local time_zone, jd, jday, fraction, jul + local year, month, julday, n, icon, day_of_week, c + + time_zone := -5.0 / 24.0 + + every year := year1 to year2 do { + every month := 1 to 12 do { + jday := julian(month, 13, year) + day_of_week := (jday + 1) % 7 + if day_of_week = 5 then { + n := integer(12.37 * (year - 1900 + integer((month - 0.5) / 12.0))) + icon := 0 + repeat { + jul := pom(n,2) + jd := jul.number + fraction := 24.0 * (jul.fraction + time_zone) + if (fraction < 0.0) then { + jd -:= 1 + fraction +:= 24.0 + } + if fraction > 12.0 then { + jd +:= 1 + fraction -:= 12.0 + } + else fraction +:= 12.0 + if jd = jday then { + suspend date2(month, year, fraction) + break + } + else { + c := if jday >= jd then 1 else -1 + if c = -icon then break + icon := c + n +:= c + } + } + } + } + } + +end + +procedure julian(month, day, year) #: Julian date + local jul, gregorian, ja, julian_year, julian_month + + gregorian := (15 + 31 * (10 + 12 * 1582)) + + if year = 0 then fail + if year < 0 then year +:= 1 + if month > 2 then { + julian_year := year + julian_month := month + 1 + } else { + julian_year := year - 1 + julian_month := month + 13 + } + jul := (integer(365.25 * julian_year) + integer(30.6001 * julian_month) + + day + 1720995) + if day + 31 * (month + 12 * year) >= gregorian then { + ja := integer(0.01 * julian_year) + jul +:= 2 - ja + integer(0.25 * ja) + } + + return jul + +end + +procedure pom(n, nph) #: phase of moon + local i, jd, fraction, radians + local am, as, c, t, t2, extra + + radians := &pi / 180 + + c := n + nph / 4.0 + t := c / 1236.85 + t2 := t * t + as := 359.2242 + 29.105356 * c + am := 306.0253 + 385.816918 * c + 0.010730 * t2 + jd := 2415020 + 28 * n + 7 * nph + extra := 0.75933 + 1.53058868 * c + ((1.178e-4) - (1.55e-7) * t) * t2 + + if nph = (0 | 2) then + extra +:= (0.1734 - 3.93e-4 * t) * sin(radians * as) - 0.4068 * + sin(radians * am) + else if nph = (1 | 3) then + extra +:= (0.1721 - 4.0e-4 * t) * sin(radians * as) - 0.6280 * + sin(radians * am) + else fail + + if extra >= 0 then i := integer(extra) + else i := integer(extra - 1.0) + jd +:= i + fraction := extra - i + + return jdate(integer(jd), fraction) + +end + +procedure saytime(time) #: time in natural English + local hour,min,mod,near,numbers,out,sec + # + # Extract the hours, minutes, and seconds from the time. + # + /time := &clock + time ? { + hour := integer(tab(find(":") | 0)) | fail + move(1) + min := tab(find(":") | 0) + move(1) + sec := tab(0) + } + min := integer(min) | 0 + sec := integer(sec) | 0 + # + # Now start the processing in earnest. + # + near := ["just gone","just after","nearly","almost"] + if sec > 29 then min +:= 1 # round up minutes + mod := min % 5 # where we are in 5 minute bracket + out := near[mod] || " " | "" # start building the result + if min > 32 then hour +:= 1 # we are TO the hour + min +:= 2 # shift minutes to straddle the 5-minute point + # + # Now special-case the result for Noon and Midnight hours. + # + if hour % 12 = 0 & min % 60 <= 4 then { + return if hour = 12 then out || "noon" + else out || "midnight" + } + min -:= min % 5 # find the nearest 5 mins + if hour > 12 then hour -:= 12 # get rid of 25-hour clock + else if hour = 0 then hour := 12 # .. and allow for midnight + # + # Determine the phrase to use for each 5-minute segment. + # + case min of { + 0: {} # add "o'clock" later + 60: min=0 # ditto + 5: out ||:= "five past" + 10: out ||:= "ten past" + 15: out ||:= "a quarter past" + 20: out ||:= "twenty past" + 25: out ||:= "twenty-five past" + 30: out ||:= "half past" + 35: out ||:= "twenty five to" + 40: out ||:= "twenty to" + 45: out ||:= "a quarter to" + 50: out ||:= "ten to" + 55: out ||:= "five to" + } + numbers := ["one","two","three","four","five","six", + "seven","eight","nine","ten","eleven","twelve"] + out ||:= (if *out = 0 then "" else " ") || numbers[hour] + # add the hour number + if min = 0 then out ||:= " o'clock" # .. and o'clock if exact + return out # return the final result +end + +procedure walltime() #: time since midnight + local seconds + + &clock ? { + seconds := tab(upto(':')) * 3600 # seconds in a hour + move(1) + seconds +:= tab(upto(':')) * 60 # seconds in a minute + move(1) + return seconds + tab(0) + } + +end diff --git a/ipl/procs/ddfread.icn b/ipl/procs/ddfread.icn new file mode 100644 index 0000000..8fdcc4c --- /dev/null +++ b/ipl/procs/ddfread.icn @@ -0,0 +1,419 @@ +############################################################################ +# +# File: ddfread.icn +# +# Subject: Procedures for reading ISO 8211 DDF files +# +# Author: Gregg M. Townsend +# +# Date: August 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures read DDF files ("Data Descriptive Files", +# ISO standard 8211) such as those specified by the US Geological +# Survey's "Spatial Data Transfer Standard" for digital maps. +# ISO8211 files from other sources may contain additional data +# encodings not recognized by these procedures. +# +# ddfopen(filename) opens a file and returns a handle. +# ddfdda(handle) returns a list of header records. +# ddfread(handle) reads the next data record. +# ddfclose(handle) closes the file. +# +############################################################################ +# +# ddfopen(filename) opens a DDF file, decodes the header, and +# returns an opaque handle for use with subsequent calls. It +# fails if any problems are encountered. Instead of a filename, +# an already-open file can be supplied. +# +############################################################################ +# +# ddfdda(handle) returns a list of records containing data +# from the Data Descriptive Area (DDA) of the file header. +# Each record contains the following fields: +# +# tag DDR entry tag +# control field control data +# name field name +# labels list of field labels +# format data format +# +# The records may also contain other fields used internally. +# +############################################################################ +# +# ddfread(handle) reads the next data record from the file. +# It returns a list of lists, with each sublist containing +# a tag name followed by the associated data values, already +# decoded according to the specification given in the header. +# +############################################################################ +# +# ddfclose(handle) closes a DDF file. +# +############################################################################ + + + +$define RecSep "\x1E" # ASCII Record Separator +$define UnitSep "\x1F" # ASCII Unit Separator +$define EitherSep '\x1E\x1F' # either separator, as cset + +$define LabelSep "!" # label separator +$define AnySep '!\x1E\x1F' # any separator, as cset + + + +record ddf_info( # basic DDF file handle + file, # underlying file + header, # last header + dlist, # DDA list (of ddf_dde records) + dtable # DDA table (indexed by tag) + ) + + +record ddf_header( # DDF header information + hcode, # header code (R if to reuse) + dlen, # data length + ddata, # dictionary data (as a string) + tsize, # size of tag field in dictionary + lsize, # size of length field + psize, # size of position field + s # header string + ) + + +record ddf_dde( # data description entry + tag, # record tag + control, # field control + name, # field name + rep, # non-null if labels repeat to end of record + labels, # list of labels + format, # format + dlist # decoder list + ) + + +record ddf_decoder( # field decoder record + proc, # decoding procedure + arg # decoder argument + ) + + + +######################### PUBLIC PROCEDURES ######################### + + + +# ddfopen(filename) -- open DDF file for input +# +# Opens a DDF file, decodes the header, and returns an opaque handle h +# for use with ddfread(h). Fails if any problems are found. + +procedure ddfopen(fname) #: open DDF file + local f, h, p, l, t, e + + if type(fname) == "file" then + f := fname + else + f := open(fname, "ru") | fail + + h := ddf_rhdr(f) | fail + p := ddf_rdata(f, h) | fail + l := dda_list(p) | fail + t := table() + every e := !l do + t[e.tag] := e + return ddf_info(f, h, l, t) +end + + + +# ddfdda(handle) -- return list of DDAs +# +# Returns a list of Data Descriptive Area records containing the +# following fields: +# +# tag DDR entry tag +# control field control data +# name field name +# labels list of field labels +# format data format +# +# (There may be other fields present for internal use.) + +procedure ddfdda(handle) + return handle.dlist +end + + + + +# ddfread(handle) -- read DDF record +# +# Reads the next record using a handle returned by ddfopen(). +# Returns a list of lists, each sublist consisting of a +# tag name followed by the associated data values + +procedure ddfread(handle) #: read DDF record + local h, p, dlist, code, data, drec, sublist, e, n + + h := handle.header + if h.hcode ~== "R" then + h := handle.header := ddf_rhdr(handle.file) | fail + p := ddf_rdata(handle.file, h) | fail + dlist := list() + while code := get(p) do { + data := get(p) + drec := \handle.dtable[code] | next # ignore unregistered code + put(dlist, sublist := [code]) + data ? { + n := -1 + while *sublist > n do { # bail out when no more progress + n := *sublist + every e := !drec.dlist do # crack according to format + every put(sublist, e.proc(e.arg)) + if pos(-1) then + =RecSep + if pos(0) then # quit more likely here + break + } + } + } + return dlist +end + + + +# ddfclose(handle) -- close DDF file + +procedure ddfclose(handle) #: close DDF file + close(\handle.file) + every !handle := &null + return +end + + + +######################### INTERNAL PROCEDURES ######################### + + + +# ddf_rhdr(f) -- read DDF header record + +procedure ddf_rhdr(f) + local s, t, tlen, hcode, off, nl, np, nx, nt, ddata + + s := reads(f, 24) | fail + *s = 24 | fail + s ? { + tlen := integer(move(5)) | fail + move(1) + hcode := move(1) + move(5) + off := integer(move(5)) | fail + move(3) | fail + nl := integer(move(1)) | fail + np := integer(move(1)) | fail + nx := move(1) | fail + nt := integer(move(1)) | fail + } + ddata := reads(f, off - 24) | fail + *ddata = off - 24 | fail + + return ddf_header(hcode, tlen - off, ddata, nt, nl, np, s) +end + + + +# ddf_rdata(f, h) -- read data, returning code/value pairs in list + +procedure ddf_rdata(f, h) + local tag, len, posn, data, a, d + + d := reads(f, h.dlen) | fail + if *d < h.dlen then fail + a := list() + h.ddata ? while not pos(0) do { + if =RecSep then break + tag := move(h.tsize) | fail + len := move(h.lsize) | fail + posn := move(h.psize) | fail + data := d[posn + 1 +: len] | fail + put(a, tag, data) + } + return a +end + + + +# dda_list(pairs) -- build DDA list from tag/data pairs + +procedure dda_list(p) + local l, labels, tag, spec, control, name, format, d, rep + + l := list() + while tag := get(p) do { + labels := list() + spec := get(p) | fail + spec ? { + control := move(6) | fail + name := tab(upto(EitherSep) | 0) + move(1) + rep := ="*" + while put(labels, tab(upto(AnySep))) do { + if =LabelSep then next + move(1) + break + } + format := tab(upto(EitherSep) | 0) + move(1) + pos(0) | fail + } + d := ddf_dtree(format) | fail + put(l, ddf_dde(tag, control, name, rep, labels, format, d)) + } + + return l +end + + + +# ddf_dtree(format) -- return tree of decoders for format +# +# keeps a cache to remember & share decoder lists for common formats + +procedure ddf_dtree(format) + static dcache + initial { + dcache := table() + dcache[""] := [ddf_decoder(ddf_str, EitherSep)] + } + + /dcache[format] := ddf_fcrack(format[2:-1]) + return dcache[format] +end + + + +# ddf_fcrack(s) -- crack format string + +procedure ddf_fcrack(s) + local dlist, n, d + + dlist := list() + s ? while not pos(0) do { + + if (any(&digits)) then + n := tab(many(&digits)) + else + n := 1 + + d := &null + d := case move(1) of { + ",": next + "A": ddf_oneof(ddf_str, ddf_strn) + "B": ddf_oneof(&null, ddf_binn, 8) + "I": ddf_oneof(ddf_int, ddf_intn) + "R": ddf_oneof(ddf_real, ddf_realn) + "(": ddf_decoder(ddf_repeat, ddf_fcrack(tab(bal(')')), move(1))) + } + if /d then fail + every 1 to n do + put(dlist, d) + } + return dlist +end + + + +# ddf_oneof(tabproc, moveproc, quantum) -- select one of two procs + +procedure ddf_oneof(tabproc, moveproc, quantum) + local d, n + + if not ="(" then + return ddf_decoder(tabproc, EitherSep) + + if any(&digits) then { + /quantum := 1 + n := integer(tab(many(&digits))) + n % quantum = 0 | fail + d := ddf_decoder(moveproc, n / quantum) + } + else { + d := ddf_decoder(\tabproc, move(1) ++ EitherSep) | fail + } + + =")" | fail + return d +end + + + +######################### DECODING PROCEDURES ######################### + + + +procedure ddf_str(cs) # delimited string + return 1(tab(upto(cs)), move(1)) +end + +procedure ddf_strn(n) # string of n characters + return move(n) +end + +procedure ddf_int(cs) # delimited integer + local s + s := tab(upto(cs)) + move(1) + return integer(s) | 0 +end + +procedure ddf_intn(n) # integer of n digits + local s + s := move(n) + return integer(s) | 0 +end + +procedure ddf_real(cs) # delimited real + local s + s := tab(upto(cs)) + move(1) + return real(s) | 0.0 +end + +procedure ddf_realn(n) # real of n digits + local s + s := move(n) + return real(s) | 0.0 +end + +procedure ddf_binn(n) # binary value of n bytes + local v, c + v := c := ord(move(1)) + every 2 to n do + v := 256 * v + ord(move(1)) + if c < 128 then # if sign bit unset in first byte + return v + else + return v - ishift(1, 8 * n) +end + +procedure ddf_repeat(lst) # repeat sublist to EOR + local e + repeat { + every e := !lst do { + if (=RecSep | &null) & pos(0) then + fail + else + suspend e.proc(e.arg) + } + } +end diff --git a/ipl/procs/dif.icn b/ipl/procs/dif.icn new file mode 100644 index 0000000..ea57134 --- /dev/null +++ b/ipl/procs/dif.icn @@ -0,0 +1,238 @@ +############################################################################ +# +# File: dif.icn +# +# Subject: Procedure to check for differences +# +# Author: Robert J. Alexander +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# dif(stream, compare, eof, group) +# generates a sequence of differences between an arbitrary +# number of input streams. Each result is returned as a list +# of diff_recs, one for each input stream, with each diff_rec +# containing a list of items that differ and their position +# in the input stream. +# +# The diff_rec type is declared as: +# +# record diff_rec(pos,diffs) +# +# dif() fails if there are no differences, i.e. it produces an empty +# result sequence. +# +############################################################################ +# +# For example, if two input streams are: +# +# a b c d e f g h +# a b d e f i j +# +# the output sequence would be: +# +# [diff_rec(3,[c]),diff_rec(3,[])] +# [diff_rec(7,[g,h]),diff_rec(6,[i,j]) +# +# The arguments to dif(stream,compare,eof,group) are: +# +# stream A list of data objects that represent input streams +# from which dif will extract its input "records". +# The elements can be of several different types which +# result in different actions, as follows: +# +# Type Action +# =========== ============================= +# file file is "read" to get records +# +# co-expression co-expression is activated to +# get records +# +# list records are "gotten" (get()) from +# the list +# +# diff_proc a record type defined in "dif" to +# allow a procedure (or procedures) +# suppled by dif's caller to be called +# to get records. Diff_proc has two +# fields, the procedure to call and the +# argument to call it with. Its +# definition looks like this: +# +# record diff_proc(proc,arg) +# +# +# Optional arguments: +# +# compare Item comparison procedure -- succeeds if +# "equal", otherwise fails (default is the +# identity "===" comparison). The comparison +# must allow for the fact that the eof object +# (see next) might be an argument, and a pair of +# eofs must compare equal. +# +# eof An object that is distinguishable from other +# objects in the stream. Default is &null. +# +# group A procedure that is called with the current number +# of unmatched items as its argument. It must +# return the number of matching items required +# for file synchronization to occur. Default is +# the formula Trunc((2.0 * Log(M)) + 2.0) where +# M is the number of unmatched items. +# +############################################################################ + +invocable all + +record diff_rec(pos,diffs) +record diff_proc(proc,arg) +record diff_file(stream,queue) + + +procedure dif(stream,compare,eof,group) + local f,linenbr,line,difflist,gf,i,j,k,l,m,n,x,test, + result,synclist,nsyncs,syncpoint + # + # Provide default arguments and initialize data. + # + /compare := proc("===",2) + /group := groupfactor + f := [] + every put(f,diff_file(!stream,[])) + linenbr := list(*stream,0) + line := list(*stream) + test := list(*stream) + difflist := list(*stream) + every !difflist := [] + # + # Loop to process all records of all input streams. + # + repeat { + # + # This is the "idle loop" where we spin until we find a discrepancy + # among the data streams. A line is read from each stream, with a + # check for eof on all streams. Then the line from the first + # stream is compared to the lines from all the others. + # + repeat { + every i := 1 to *stream do + line[i] := diffread(f[i]) | eof + if not (every x := !line do + (x === eof) | break) then break break + every !linenbr +:= 1 + if (every x := !line[2:0] do + compare(x,line[1]) | break) then break + } + # + # Aha! We have found a difference. Create a difference list, + # one entry per stream, primed with the differing line we just found. + # + every i := 1 to *stream do + difflist[i] := [line[i]] + repeat { + # + # Add a new input line from each stream to the difference list. + # Then build lists of the subset of different lines we need to + # actually compare. + # + every i := 1 to *stream do + put(difflist[i],diffread(f[i]) | eof) + gf := group(*difflist[1]) + every i := 1 to *stream do + test[i] := difflist[i][-gf:0] + # + # Create a "synchronization matrix", with a row and column for + # each input stream. The entries will be initially &null, then + # will be set to the synchronization position if sync is + # achieved between the two streams. Another list is created to + # keep track of how many syncs have been achieved for each stream. + # + j := *difflist[1] - gf + 1 + synclist := list(*stream) + every !synclist := list(*stream) + every k := 1 to *stream do + synclist[k][k] := j + nsyncs := list(*stream,1) + # + # Loop through positions to start comparing lines. This set of + # nested loops will be exited when a stream achieves sync with + # all other streams. + # + every i := 1 to j do { + # + # Loop through all streams. + # + every k := 1 to *stream do { + # + # Loop through all streams. + # + every l := 1 to *stream do { + if /synclist[k][l] then { # avoid unnecessary comparisons + # + # Compare items of the test list to the differences list + # at all possible positions. If they compare, store the + # current position in the sync matrix and bump the count + # of streams sync'd to this stream. If all streams are in + # sync, exit all loops but the outer one. + # + m := i - 1 + if not every n := 1 to gf do { + if not compare(test[k][n],difflist[l][m +:= 1]) then break + } then { + synclist[k][l] := i # store current position + if (nsyncs[k] +:= 1) = *stream then break break break break + } + } + } + } + } + } + # + # Prepare an output set. Since we have read the input streams past + # the point of synchronization, we must queue those lines before their + # input streams. + # + synclist := synclist[k] + result := list(*stream) + every i := 1 to *stream do { + j := synclist[i] + while difflist[i][j -:= 1] === eof # trim past eof + result[i] := diff_rec(linenbr[i],difflist[i][1:j + 1]) + f[i].queue := difflist[i][synclist[i] + gf:0] ||| f[i].queue + linenbr[i] +:= synclist[i] + gf - 2 + difflist[i] := [] + } + suspend result + } +end + +# +# diffread() -- Read a line from an input stream. +# +procedure diffread(f) + local x + return get(f.queue) | case type(x := f.stream) of { + "file" | "window": read(x) + "co-expression": @x + "diff_proc": x.proc(x.arg) + "list": get(x) + } +end + +# +# groupfactor() -- Determine how many like lines we need to close +# off a group of differences. This is the default routine -- the +# caller may provide his own. +# +procedure groupfactor(m) # Compute: Trunc((2.0 * Log(m)) + 2.0) + m := string(m) + return 2 * *m + if m <<= "316227766"[1+:*m] then 0 else 1 +end + diff --git a/ipl/procs/digitcnt.icn b/ipl/procs/digitcnt.icn new file mode 100644 index 0000000..e657f23 --- /dev/null +++ b/ipl/procs/digitcnt.icn @@ -0,0 +1,37 @@ +############################################################################ +# +# File: digitcnt.icn +# +# Subject: Procedure to count number of digits in file +# +# Author: Ralph E. Griswold +# +# Date: July 15, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure counts the number of each digit in a file and returns +# a ten-element list with the counts. +# +############################################################################ + +procedure digitcnt(file) #: count digits in file + local result + + /file := &input + + result := list(10, 0) + + # If the file contains only digits, remove the # on the next line and add + # to the following one. + +# every result[!!file + 1] +:= 1 + every result[integer(!!file) + 1] +:= 1 + + return result + +end diff --git a/ipl/procs/dijkstra.icn b/ipl/procs/dijkstra.icn new file mode 100644 index 0000000..b92ece5 --- /dev/null +++ b/ipl/procs/dijkstra.icn @@ -0,0 +1,201 @@ +############################################################################ +# +# File: dijkstra.icn +# +# Subject: Procedures for Dijkstra's "Discipline" control structures +# +# Author: Frank J. Lhota +# +# Date: December 9, 2003 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# The procedures do_od and if_fi implement the "do ... od" and "if ... fi" +# control structures used in the book "A Discipline of Programming" by +# Edsger W. Dijkstra. This book uses a programming language designed to +# delay implementation details, such as the order in which tests are +# performed. +# +# Dijkstra's programming language uses two non-ASCII characters, a box and +# a right arrow. In the following discussion, the box and right arrow +# characters are represented as "[]" and "->" respectively. +# +# The "if ... fi" control structure is similar to multi-branch "if" statements +# found in many languages, including the Bourne shell (i.e. the +# "if / elif / fi" construct). The major difference is that in Dijkstra's +# notation, there is no specified order in which the "if / elif" tests are +# performed. The "if ... fi" structure has the form +# +# if +# Guard1 -> List1 +# [] Guard2 -> List2 +# [] Guard3 -> List3 +# ... +# [] GuardN -> ListN +# fi +# +# where +# +# Guard1, Guard2, Guard3 ... GuardN are boolean expressions, and +# List1, List2, List3 ... ListN are lists of statements. +# +# When this "if ... fi" statement is performed, the guard expressions are +# evaluated, in some order not specified by the language, until one of the +# guard expressions evaluates to true. Once a true guard is found, the list +# of statements following the guard is evaluated. It is a fatal error +# for none of the guards in an "if ... fi" statement to be true. +# +# The "do ... od" control is a "while" loop structure, but with multiple +# loop conditions, in style similar to "if ... fi". The form of a Dijkstra +# "do" statement is +# +# do +# Guard1 -> List1 +# [] Guard2 -> List2 +# [] Guard3 -> List3 +# ... +# [] GuardN -> ListN +# od +# +# where +# +# Guard1, Guard2, Guard3 ... GuardN are boolean expressions, and +# List1, List2, List3 ... ListN are lists of statements. +# +# To perform this "do ... od" statement, the guard expressions are +# evaluated, in some order not specified by the language, until either a +# guard evaluates to true, or all guards have been evaluated as false. +# +# - If all the guards are false, we exit the loop. +# - If a guard evaluates to true, then the list of statements following this +# guard is performed, and then we loop back to perform this "do ... od" +# statement again. +# +# The procedures if_fi{} and do_od{} implement Dijkstra's "if ... fi" and +# "do ... od" control structures respectively. In keeping with Icon +# conventions, the guard expressions are arbitrary Icon expressions. A guard +# is considered to be true precisely when it succeeds. Similarly, a statement +# list can be represented by a single Icon expression. The Icon call +# +# if_fi{ +# Guard1, List1, +# Guard2, List2, +# ... +# GuardN, ListN +# } +# +# suspends with each result produced by the expression following the true +# guard. If none of the guards succeed, runerr() is called with an appropriate +# message. +# +# Similarly, the Icon call +# +# do_od{ +# Guard1, List1, +# Guard2, List2, +# ... +# GuardN, ListN +# } +# +# parallels the "do ... od" statement. As long as at least one guard +# succeeds, another iteration is performed. When all guards fail, we exit +# the loop and do_od fails. +# +# The test section of this file includes a guarded command implementation of +# Euclid's algorithm for calculating the greatest common denominator. Unlike +# most implementations of Euclid's algorithm, this version handles its +# parameters in a completely symmetrical fashion. +# +############################################################################ +# +# Links: none +# +############################################################################ + +############################################################################ +# +# Produces a set of the indices of all the guard expressions in exp. +# +############################################################################ +procedure __Dijkstra_guard_index_set(exp) + local result + + result := set() + every insert(result, 1 to *exp by 2) + return result + +end # __Dijkstra_guard_index_set + +############################################################################ + +procedure do_od(exp) #: Dijkstra's do_od construct + + local all_guards, curr_guard + + all_guards := __Dijkstra_guard_index_set(exp) + + # Remember to use refreshed co-expressions so that they can be evaluated + # more than once! + while @^exp[ curr_guard := !all_guards ] do + @^exp[ curr_guard + 1 ] + +end # do_od + +############################################################################ + +procedure if_fi(exp) #: Dijkstra's if_fi construct + + local all_guards, curr_guard + + all_guards := __Dijkstra_guard_index_set(exp) + + if @exp[ curr_guard := !all_guards ] then + suspend | @exp[ curr_guard + 1 ] + else + runerr(500, "if_fi: no guards succeeded") + +end # if_fi + +$ifdef TEST + +############################################################################ +# +# Dijkstra version of the familiar Euclidean algorithm for gcd. +# +############################################################################ +procedure gcd(x, y) + + # Use static variables so that co-expressions can share them + static lx, ly + + lx := abs(x) + ly := abs(y) + + do_od{ + lx >= ly > 0, lx %:= ly, + ly >= lx > 0, ly %:= lx + } + + return if_fi{ + lx = 0, ly, + ly = 0, lx + } + +end # gcd + +procedure main(arg) + + local a, b + + a := integer(arg[1]) | 1836311903 + b := integer(arg[2]) | 1134903170 + return write("gcd(", a, ",", b,")=",gcd(a, b)) + +end # main + + +$endif diff --git a/ipl/procs/divide.icn b/ipl/procs/divide.icn new file mode 100644 index 0000000..feff859 --- /dev/null +++ b/ipl/procs/divide.icn @@ -0,0 +1,45 @@ +############################################################################ +# +# File: divide.icn +# +# Subject: Procedure to perform long division +# +# Author: Ralph E. Griswold +# +# Date: March 29, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Doesn't get the decimal point. Not sure what the padding does; +# to study. +# +############################################################################ +# +# Requires: Large integer arithmetic, potentially +# +############################################################################ + +procedure divide(i, j, k) # long division + local q, pad + + /k := 5 + + q := "" + + pad := 20 + + i ||:= repl("0", pad) + + every 1 to k do { + q ||:= i / j + i %:= j + if i = 0 then break + } + + return q[1:-pad] + +end diff --git a/ipl/procs/ebcdic.icn b/ipl/procs/ebcdic.icn new file mode 100644 index 0000000..213716f --- /dev/null +++ b/ipl/procs/ebcdic.icn @@ -0,0 +1,161 @@ +############################################################################ +# +# File: ebcdic.icn +# +# Subject: Procedures to convert between ASCII and EBCDIC +# +# Author: Alan Beale +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures assist in use of the ASCII and EBCDIC character sets, +# regardless of the native character set of the host: +# +# Ascii128() Returns a 128-byte string of ASCII characters in +# numerical order. Ascii128() should be used in +# preference to &ascii for applications which might +# run on an EBCDIC host. +# +# Ascii256() Returns a 256-byte string representing the 256- +# character ASCII character set. On an EBCDIC host, +# the order of the second 128 characters is essentially +# arbitrary. +# +# Ebcdic() Returns a 256-byte string of EBCDIC characters in +# numerical order. +# +# AsciiChar(i) Returns the character whose ASCII representation is i. +# +# AsciiOrd(c) Returns the position of the character c in the ASCII +# collating sequence. +# +# EbcdicChar(i) Returns the character whose EBCDIC representation is i. +# +# EbcdicOrd(c) Returns the position of the character c in the EBCDIC +# collating sequence. +# +# MapEtoA(s) Maps a string of EBCDIC characters to the equivalent +# ASCII string, according to a plausible mapping. +# +# MapAtoE(s) Maps a string of ASCII characters to the equivalent +# EBCDIC string, according to a plausible mapping. +# +# Control(c) Returns the "control character" associated with the +# character c. On an EBCDIC host, with $ representing +# an EBCDIC character with no 7-bit ASCII equivalent, +# Control("$") may not be identical to "\^$", as +# translated by ICONT (and neither result is particularly +# meaningful). +# +############################################################################ +# +# Notes: +# +# There is no universally accepted mapping between ASCII and EBCDIC. +# See the SHARE Inc. publication "ASCII and EBCDIC Character Set and +# Code Issues in Systems Application Architecture" for more information +# than you would ever want to have on this subject. +# +# The mapping of the first 128 characters defined below by Ascii128() +# is the most commonly accepted mapping, even though it probably +# is not exactly like the mapping used by your favorite PC to mainframe +# file transfer utility. The mapping of the second 128 characters +# is quite arbitrary, except that where an alternate translation of +# ASCII char(n) is popular, this translation is assigned to +# Ascii256()[n+129]. +# +# The behavior of all functions in this package is controlled solely +# by the string literals in the _Eascii() procedure. Therefore you +# may modify these strings to taste, and still obtain consistent +# results, provided that each character appears exactly once in the +# result of _Eascii(). +# +# Yes, it's really true that the EBCDIC "\n" (NL, char(16r15)) is not +# the same as "\l" (LF, char(16r25)). How can that be? "Don't blame +# me, man, I didn't do it." +# +############################################################################ + +procedure _Eascii() + static EinAorder + initial + EinAorder := +# NUL SOH STX ETX EOT ENQ ACK BEL BS HT NL VT FF CR SO SI + "\x00\x01\x02\x03\x37\x2d\x2e\x2f\x16\x05\x15\x0b\x0c\x0d\x0e\x0f"|| +# DLE DC1 DC2 DC3 DC4 NAK SYN ETB CAN EM SUB ESC FS GS RS US + "\x10\x11\x12\x13\x3c\x3d\x32\x26\x18\x19\x3f\x27\x1c\x1d\x1e\x1f"|| +# sp ! " # $ % & ' ( ) * + , - . / + "\x40\x5a\x7f\x7b\x5b\x6c\x50\x7d\x4d\x5d\x5c\x4e\x6b\x60\x4b\x61"|| +# 0 1 2 3 4 5 6 7 8 9 : ; < = > ? + "\xf0\xf1\xf2\xf3\xf4\xf5\xf6\xf7\xf8\xf9\x7a\x5e\x4c\x7e\x6e\x6f"|| +# @ A B C D E F G H I J K L M N O + "\x7c\xc1\xc2\xc3\xc4\xc5\xc6\xc7\xc8\xc9\xd1\xd2\xd3\xd4\xd5\xd6"|| +# P Q R S T U V W X Y Z $< \ $> ^ _ + "\xd7\xd8\xd9\xe2\xe3\xe4\xe5\xe6\xe7\xe8\xe9\xad\xe0\xbd\x5f\x6d"|| +# ` a b c d e f g h i j k l m n o + "\x79\x81\x82\x83\x84\x85\x86\x87\x88\x89\x91\x92\x93\x94\x95\x96"|| +# p q r s t u v w x y z $( | $) ~ DEL + "\x97\x98\x99\xa2\xa3\xa4\xa5\xa6\xa7\xa8\xa9\xc0\x4f\xd0\xa1\x07"|| + "\x04\x06\x08\x09\x0a\x14\x17\x1a\x1b\x20\x25\x21\x22\x23\x24\x28_ + \x29\x2a\x2b\x2c\x30\x31\x33\x34\x35\x36\x38\x39\x3a\x3b\x3e\xff_ + \x41\x42\x43\x44\x4a\x45\x46\x47\x48\x49\x51\x52\x53\x54\x55\x56_ + \x57\x58\x59\x62\x63\x64\x65\x66\x67\x68\x69\x70\x71\x72\x73\x74_ + \x75\x76\x77\x78\x80\x8a\x8c\x8d\x8e\x8f\x90\x9a\x9c\x9d\x9e\x9f_ + \xa0\xaa\xab\xac\xae\xaf\xb0\xb1\xb2\xb3\xb4\xb5\xb6\xb7\xb8\xb9_ + \xba\xbb\xbc\xbe\xbf\xca\xcb\xcc\xcd\xce\xcf\xda\xdb\xdc\xdd\xde_ + \xdf\xe1\xea\xeb\xec\xed\xee\xef\xfa\xfb\xfc\x8b\x6a\x9b\xfd\xfe" + return EinAorder +end + +procedure Ascii128() + if "\l" == "\n" then return string(&ascii) + return _Eascii()[1+:128] +end + +procedure Ascii256() + if "\l" == "\n" then return string(&cset) + return _Eascii() +end + +procedure Ebcdic() + if "\l" ~== "\n" then return &cset + return map(&cset, _Eascii(), &cset) +end + +procedure AsciiChar(i) + if "\l" == "\n" then return char(i) + return _Eascii()[0 < i+1] | runerr(205,i) +end + +procedure AsciiOrd(c) + if "\l" == "\n" then return ord(c) + return ord(MapEtoA(c)) +end + +procedure EbcdicChar(i) + if "\l" ~== "\n" then return char(i) + return map(char(i), _Eascii(), &cset) +end + +procedure EbcdicOrd(c) + if "\l" ~== "\n" then return ord(c) + return ord(MapAtoE(c)) +end + +procedure MapEtoA(s) + return map(s, _Eascii(), &cset) +end + +procedure MapAtoE(s) + return map(s, &cset, _Eascii()) +end + +procedure Control(c) + return AsciiChar(iand(AsciiOrd(c),16r1f)) +end diff --git a/ipl/procs/empgsup.icn b/ipl/procs/empgsup.icn new file mode 100644 index 0000000..8268f3d --- /dev/null +++ b/ipl/procs/empgsup.icn @@ -0,0 +1,43 @@ +############################################################################ +# +# File: empgsup.icn +# +# Subject: Procedure to support empg +# +# Author: Ralph E. Griswold +# +# Date: May 30, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure is called by timing programs produced by empg. It +# a "delta" timing value used to adjust timings. +# +############################################################################ + +procedure _Initialize(limit) + local itime, t1, t3 + + itime := &time + + every 1 to limit do { + &null + } + + t1 := (&time - itime) + + itime := &time + + every 1 to limit do { + &null & &null + } + + t3 := (&time - itime) + + return (t1 + t3) / 2 + +end diff --git a/ipl/procs/emptygen.icn b/ipl/procs/emptygen.icn new file mode 100644 index 0000000..3ca922a --- /dev/null +++ b/ipl/procs/emptygen.icn @@ -0,0 +1,220 @@ +############################################################################ +# +# File: emptygen.icn +# +# Subject: Procedures for meta-translation code generation +# +# Author: Ralph E. Griswold +# +# Date: December 5, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program is designed to be linked with the output of the meta- +# translator. As given here, they produce an identity translation. +# Modifications can be made to effect different translations. +# +# The procedures here are just wrappers. This file is a skeleton that +# can be used as a basis for code-generation procedures. +# +############################################################################ +# +# Bug: The invocable declaration is not handled properly. "invocable all" +# will get by, but some other forms produce syntax errors. The +# problem is in the meta-translator itself, not in this program. +# +############################################################################ +# +# Links: strings +# +############################################################################ + +link strings + +procedure main() + + Mp() # call meta-procedure + +end + +procedure Alt(e1, e2) # e1 | e2 +end + +procedure Apply(e1, e2) # e1 ! e2 +end + +procedure Arg(e) # procedure argument (parameter) +end + +procedure Asgnop(op, e1, e2) # e1 op e2 +end + +procedure Augscan(e1, e2) # e1 ?:= e2 +end + +procedure Bamper(e1, e2) # e1 & e2 +end + +procedure Binop(op, e1, e2) # e1 op e2 +end + +procedure Body(es[]) # procedure body +end + +procedure Break(e) # break e +end + +procedure Case(e, clist) # case e of { caselist } +end + +procedure Cclause(e1, e2) # e1 : e2 +end + +procedure Clist(cclause1, cclause2) # cclause1 ; cclause2 +end + +procedure Clit(c) # 'c' +end + +procedure Compound(es[]) # { e1; e2; ... } +end + +procedure Create(e) # create e +end + +procedure Default(e) # default: e +end + +procedure End() # end +end + +procedure Every(e) # every e +end + +procedure EveryDo(e1, e2) # every e1 do e2 +end + +procedure Fail() # fail +end + +procedure Field(e, f) # e . f +end + +procedure Global(vs[]) # global v1, v2, ... +end + +procedure If(e1, e2) # if e1 then e2 +end + +procedure IfElse(e1, e2, e3) # if e1 then e2 else e3 +end + +procedure Ilit(i) # i +end + +procedure Initial(e) # initial e +end + +procedure Invocable(ss[]) # invocable s1, s2, ... (problem) +end + +procedure Invoke(e, es[]) # e(e1, e2, ...) +end + +procedure Key(s) # &s +end + +procedure Limit(e1, e2) # e1 \ e2 +end + +procedure Link(vs[]) # link "v1, v2, ..." +end + +procedure List(es[]) # [e1, e2, ... ] +end + +procedure Local(vs[]) # local v1, v2, ... +end + +procedure Next() # next +end + +procedure Not(e) # not e +end + +procedure Null() # &null +end + +procedure Paren(es[]) # (e1, e2, ... ) +end + +procedure Pdco(e, es[]) # e{e1, e2, ... } +end + +procedure Proc(n, vs[]) # procedure n(v1, v2, ...) +end + +procedure Record(n, fs[]) # record n(f1, f2, ...) +end + +procedure Repeat(e) # repeat e +end + +procedure Return(e) # return e +end + +procedure Rlit(r) # r +end + +procedure Scan(e1, e2) # e1 ? e2 +end + +procedure Section(op, e1, e2, e3) # e1[e2 op e3] +end + +procedure Slit(s) # "s" +end + +procedure Static(vs[]) # static v1, v2, .. +end + +procedure Subscript(e1, e2) # e1[e2] +end + +procedure Suspend(e) # suspend e +end + +procedure SuspendDo(e1, e2) # suspend e1 do e2 +end + +procedure To(e1, e2) # e1 to e2 +end + +procedure ToBy(e1, e2, e3) # e1 to e2 by e3 +end + +procedure Repalt(e) # |e +end + +procedure Unop(op, e) # op e +end + +procedure Until(e) # until e +end + +procedure UntilDo(e1, e2) # until e1 do e2 +end + +procedure Var(v) # v +end + +procedure While(e) # while e +end + +procedure WhileDo(e1, e2) # while e1 do e2 +end + diff --git a/ipl/procs/equiv.icn b/ipl/procs/equiv.icn new file mode 100644 index 0000000..8af52d1 --- /dev/null +++ b/ipl/procs/equiv.icn @@ -0,0 +1,91 @@ +############################################################################ +# +# File: equiv.icn +# +# Subject: Procedure to compare structures +# +# Author: Ralph E. Griswold +# +# Date: February 20, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# equiv(s,y) compare arbitrary structures x and y +# +############################################################################ +# +# The procedure equiv() tests for the "equivalence" of two values. For types +# other than structures, it does the same thing as x1 === x2. For structures, +# the test is for "shape". For example, +# +# equiv([],[]) +# +# succeeds. +# +# It handles loops, but does not recognize them as such. For example, +# given +# +# L1 := [] +# L2 := [] +# put(L1,L1) +# put(L2,L1) +# +# equiv(L1,L2) +# +# succeeds. +# +# The concept of equivalence for tables and sets is not quite right +# if their elements are themselves structures. The problem is that there +# is no concept of order for tables and sets, yet it is impractical to +# test for equivalence of their elements without imposing an order. Since +# structures sort by "age", there may be a mismatch between equivalent +# structures in two tables or sets. +# +# Note: +# The procedures equiv and ldag have a trailing argument that is used on +# internal recursive calls; a second argument must not be supplied +# by the user. +# +############################################################################ + +procedure equiv(x1,x2,done) #: compare values for equivalence + local code, i + + if x1 === x2 then return x2 # Covers everything but structures. + + if type(x1) ~== type(x2) then fail # Must be same type. + + if type(x1) == ("procedure" | "file" | "window") + then fail # Leave only those with sizes (null + # taken care of by first two tests). + + if *x1 ~= *x2 then fail # Skip a lot of possibly useless work. + + # Structures (and others) remain. + + /done := table() # Basic call. + + (/done[x1] := set()) | # Make set of equivalences if new. + (if member(done[x1],x2) then return x2) + + # Records complicate things. + image(x1) ? (code := (="record" | type(x1))) + + case code of { + "list" | "record": + every i := 1 to *x1 do + if not equiv(x1[i],x2[i],done) then fail + "table": if not equiv(sort(x1,3),sort(x2,3),done) then fail + "set": if not equiv(sort(x1),sort(x2),done) then fail + default: fail # Vaues of other types are different. + } + + insert(done[x1],x2) # Equivalent; add to set. + return x2 + +end + diff --git a/ipl/procs/escape.icn b/ipl/procs/escape.icn new file mode 100644 index 0000000..0a6ea6f --- /dev/null +++ b/ipl/procs/escape.icn @@ -0,0 +1,100 @@ +############################################################################ +# +# File: escape.icn +# +# Subject: Procedures to interpret Icon literal escapes +# +# Authors: William H. Mitchell +# +# Date: April 16, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Contributors: Ralph E. Griswold and Alan Beale +# +############################################################################ +# +# The procedure escape(s) produces a string in which Icon quoted +# literal escape conventions in s are replaced by the corresponding +# characters. For example, escape("\\143\\141\\164") produces the +# string "cat". +# +############################################################################ +# +# Links: ebcdic +# +############################################################################ + +link ebcdic + +procedure escape(s) + local ns, c + + ns := "" + s ? { + while ns ||:= tab(upto('\\')) do { + move(1) + ns ||:= case map(c := move(1)) | fail of { # trailing \ illegal + "b": "\b" + "d": "\d" + "e": "\e" + "f": "\f" + "l": "\n" + "n": "\n" + "r": "\r" + "t": "\t" + "v": "\v" + "x": hexcode() + "^": ctrlcode() + !"01234567": octcode() + default: c # takes care of ", ', and \ + } + } + return ns || tab(0) + } + +end + +procedure hexcode() + local i, s + + s := tab(many('0123456789ABCDEFabcdef')) | "" # get hex digits + + if (i := *s) > 2 then { # if too many digits, back off + s := s[1:3] + move(*s - i) + } + + return char("16r" || s) + +end + +procedure octcode() + local i, s + + move(-1) # put back first octal digit + s := tab(many('01234567')) | "" # get octal digits + + i := *s + if (i := *s) > 3 then { # back off if too large + s := s[1:4] + move(*s - i) + } + if s > 377 then { # still could be too large + s := s[1:3] + move(-1) + } + + return char("8r" || s) + +end + +procedure ctrlcode(s) + + return Control(move(1)) + +end diff --git a/ipl/procs/escapesq.icn b/ipl/procs/escapesq.icn new file mode 100644 index 0000000..052dec6 --- /dev/null +++ b/ipl/procs/escapesq.icn @@ -0,0 +1,129 @@ +############################################################################ +# +# File: escapesq.icn +# +# Subject: Procedures to deal with character string escapes +# +# Author: Robert J. Alexander +# +# Date: May 13, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Procedure kit for dealing with escape sequences in Icon character +# string representations. Note that Icon escape sequences are +# very similar to C escapes, so this works for C strings, too. +# +# escapeseq() -- a matching procedure for Icon string escape sequences +# +# escchar() -- produces the character value of an Icon string escape sequence +# +# escape() -- converts a string with escape sequences (as in Icon string +# representation) to the string it represents with escape +# +# quotedstring() -- matching routine for a quoted string. +# +############################################################################ + +procedure escapeseq() # s +# +# Matching routine for Icon string escape sequence. +# + static oct,hex + initial { + oct := '01234567' + hex := '0123456789ABCDEFabcdef' + } + return ( + ="\\" || + ( + tab(any('bdeflnrtvBDEFLNRTV\'"\\')) | + tab(any(oct)) || (tab(any(oct)) | "") || (tab(any(oct)) | "") | + tab(any('xX')) || tab(any(hex)) || (tab(any(hex)) | "") | + ="^" || move(1) + ) + ) +end + + +procedure escchar(s1) # s2 +# +# Character value of Icon string escape sequence s1. +# + local c + s1 ? { + ="\\" + return 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": escchar_convert(16,2) # hexadecimal code + "^": char(ord(move(1)) % 32) | &fail # control code + default: { # either octal code or non-escaped character + if any('01234567',c) then { # if octal digit + move(-1) + escchar_convert(8,3) + } + else c # else return escaped character + } + } + } +end + + +procedure escchar_convert(r,max) +# +# Private utility procedure used by escchar -- performs conversion +# of numeric character strings of radix "r", where 2 <= r <= 16. +# The procedure operates in a string scanning context, and will +# consume a maximum of "max" characters. +# + 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 + + +procedure escape(s1) # s2 +# +# Returns string s1 with escape sequences (as in Icon string +# representation) converted. +# + local esc + s1 ? { + s1 := "" + while s1 ||:= tab(find("\\")) do { + if esc := escapeseq() then s1 ||:= escchar(esc) + else move(1) + } + s1 ||:= tab(0) + } + return s1 +end + + +procedure quotedstring() # s +# +# Matching routine for a quoted string. +# + suspend ="\"" || 1(tab(find("\"") + 1),&subject[&pos - 2] ~== "\\") +end diff --git a/ipl/procs/eval.icn b/ipl/procs/eval.icn new file mode 100644 index 0000000..696e6a3 --- /dev/null +++ b/ipl/procs/eval.icn @@ -0,0 +1,68 @@ +############################################################################ +# +# File: eval.icn +# +# Subject: Procedure to evaluate string as a call +# +# Author: Ralph E. Griswold +# +# Date: March 3, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure analyzes a string representing an Icon function or +# procedure call and evaluates the result. Operators can be +# used in functional form, as in "*(2,3)". +# +# This procedure cannot handle nested expressions or control structures. +# +# It assumes the string is well-formed. The arguments can only be +# Icon literals. Escapes, commas, and parentheses in strings literals +# are not handled. +# +# In the case of operators that are both unary and binary, the binary +# form is used. +# +############################################################################ +# +# Links: ivalue +# +############################################################################ + +invocable all + +link ivalue + +procedure eval(expr) + local p, args, tok + + &error := -1 # to prevent error termination ... + + expr ? { + p := trim(tab(upto('(')), '\t ') | { + write(&errout, "*** syntax error") + fail + } + p := proc(p, 2 | 1 | 3) | { + write(&errout, "*** invalid operation") + fail + } + move(1) + + args := [] + + repeat { + tab(many(' \t')) + tok := trim(tab(upto(',)'))) | break + put(args, ivalue(tok)) | fail # fail on syntax error + move(1) + } + + suspend p ! args + } + +end diff --git a/ipl/procs/evallist.icn b/ipl/procs/evallist.icn new file mode 100644 index 0000000..d095950 --- /dev/null +++ b/ipl/procs/evallist.icn @@ -0,0 +1,50 @@ +############################################################################ +# +# File: evallist.icn +# +# Subject: Procedure to produce a list generated by expression +# +# Author: Ralph E. Griswold +# +# Date: July 15, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure takes an expression, produces a program encapsulating it, +# and puts the results written by the program in a list. +# +# It is called as evallist(expr, n, ucode, ...) where expr is an expression +# (normally a generator), n is the maximum size of the list, and the +# trailing arguments are ucode files to link with the expression. +# +############################################################################ +# +# Requires: system(), /tmp, pipes +# +############################################################################ +# +# Links: exprfile +# +############################################################################ + +link exprfile + +procedure evallist(expr, n, ucode[]) #: list of values generated by Icon expression + local input, result + + push(ucode, expr) # put expression first + + input := exprfile ! ucode | fail + + result := [] + every put(result, !input) \ n + + exprfile() # clean up + + return result + +end diff --git a/ipl/procs/eventgen.icn b/ipl/procs/eventgen.icn new file mode 100644 index 0000000..d312100 --- /dev/null +++ b/ipl/procs/eventgen.icn @@ -0,0 +1,495 @@ +############################################################################ +# +# File: eventgen.icn +# +# Subject: Procedures for meta-variant code generation +# +# Author: Ralph E. Griswold +# +# Date: May 23, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program is designed to be linked with the output of the meta-variant +# translator. +# +# It is designed to insert event-reporting code in Icon programs. +# +############################################################################ +# +# Bug: The invocable declaration is not handled properly. "invocable all" +# will get by, but some other forms produce syntax errors. The +# problem is in the meta-variant translator itself, not in this +# program. +# +############################################################################ +# +# Links: strings +# +############################################################################ + +global procname + +link strings + +# main() calls tp(), which is produced by the meta-variant +# translation. + +procedure main() + + write("$define MAssign 1") + write("$define MValue 2") + write("procedure noop()") + write("end") + + Mp() + +end + +procedure Alt(e1, e2) # e1 | e2 + + return cat("(", e1, "|", e2, ")") + +end + +procedure Apply(e1, e2) # e1 ! e2 + + return cat("(", e1, "!", e2, ")") + +end + +procedure Arg(e) + + return e + +end + +procedure Asgnop(op, e1, e2) # e1 op e2 + + return cat("2(event(MAssign, ", image(e1) , "), ", + e1, " ", op, " ", e2, ", event(MValue, ", e1, "))") + +end + +procedure Augscan(e1, e2) # e1 ?:= e2 + + return cat("(", e1, " ?:= ", e2, ")") + +end + +procedure Bamper(e1, e2) # e1 & e2 + + return cat("(", e1, " & ", e2, ")") + +end + +procedure Binop(op, e1, e2) # e1 op e2 + + return cat("(", e1, " ", op, " ", e2, ")") + +end + +procedure Body(s[]) # procedure body + + if procname == "main" then + write(" if &source === &main then event := noop") + + every write(!s) + + return + +end + +procedure Break(e) # break e + + return cat("break ", e) + +end + +procedure Case(e, clist) # case e of { caselist } + + return cat("case ", e, " of {", clist, "}") + +end + +procedure Cclause(e1, e2) # e1 : e2 + + return cat(e1, " : ", e2, "\n") + +end + +procedure Clist(e1, e2) # e1 ; e2 in case list + + return cat(e1, ";", e2) + +end + +procedure Clit(e) # 's' + +# return cat("'", e, "'") + return image(e) + +end + +procedure Compound(es[]) # { e1; e2; ... } + local result + + if *es = 0 then return "{}\n" + + result := "{\n" + every result ||:= !es || "\n" + + return cat(result, "}\n") + +end + +procedure Create(e) # create e + + return cat("create ", e) + +end + +procedure Default(e) # default: e + + return cat("default: ", e) + +end + +procedure End() # end + + write("end") + + return + +end + +procedure Every(e) # every e + + return cat("every ", e) + +end + +procedure EveryDo(e1, e2) # every e1 do e2 + + return cat("every ", e1, " do ", e2) + +end + +procedure Fail() # fail + + return "fail" + +end + +procedure Field(e1, e2) # e . f + + return cat("(", e1, ".", e2, ")") + +end + +procedure Global(vs[]) # global v1, v2, ... + local result + + result := "" + every result ||:= !vs || ", " + + write("global ", result[1:-2]) + + return + +end + +procedure If(e1, e2) # if e1 then e2 + + return cat("if ", e1, " then ", e2) + +end + +procedure IfElse(e1, e2, e3) # if e1 then e2 else e3 + + return cat("if ", e1, " then ", e2, " else ", e3) + +end + +procedure Ilit(e) # i + + return e + +end + +procedure Initial(s) # initial e + + write("initial ", s) + + return + +end + +procedure Invocable(es[]) # invocable ... (problem) + + if \es then write("invocable all") + else write("invocable ", es) + + return + +end + +procedure Invoke(e0, es[]) # e0(e1, e2, ...) + local result + + if *es = 0 then return cat(e0, "()") + + result := "" + every result ||:= !es || ", " + + return cat(e0, "(", result[1:-2], ")") + +end + +procedure Key(s) # &s + + return cat("&", s) + +end + +procedure Limit(e1, e2) # e1 \ e2 + + return cat("(", e1, "\\", e2, ")") + +end + +procedure Link(vs[]) # link "v1, v2, ..." + + local result + + result := "" + every result ||:= !vs || ", " + + write("link ", result[1:-2]) + + return + +end + +procedure List(es[]) # [e1, e2, ... ] + local result + + if *es = 0 then return "[]" + + result := "" + every result ||:= !es || ", " + + return cat("[", result[1:-2], "]") + +end + +procedure Local(vs[]) # local v1, v2, ... + local result + + result := "" + every result ||:= !vs || ", " + + write("local ", result[1:-2]) + + return + +end + +procedure Next() # next + + return "next" + +end + +procedure Not(e) # not e + + return cat("not(", e, ")") + +end + +procedure Null() # &null + + return "" + +end + +procedure Paren(es[]) # (e1, e2, ... ) + local result + + if *es = 0 then return "()" + + result := "" + every result ||:= !es || ", " + + return cat("(", result[1:-2], ")") + +end + +procedure Pdco(e0, es[]) # e0{e1, e2, ... } + local result + + if *es = 0 then return cat(e0, "{}") + + result := "" + every result ||:= !es || ", " + + return cat(e0, "{", result[1:-2], "}") + +end + +procedure Proc(s, es[]) # procedure s(v1, v2, ...) + local result, e + + if *es = 0 then write("procedure ", s, "()") + + result := "" + every e := !es do + if \e == "[]" then result[-2:0] := e || ", " + else result ||:= (\e | "") || ", " + + write("procedure ", s, "(", result[1:-2], ")") + + procname := s # needed later + + return + +end + +procedure Record(s, es[]) # record s(v1, v2, ...) + local result, field + + if *es = 0 then write("record ", s, "()") + + result := "" + every field := !es do + result ||:= (\field | "") || ", " + + write("record ", s, "(", result[1:-2], ")") + + return + +end + +procedure Repeat(e) # repeat e + + return cat("repeat ", e) + +end + +procedure Return(e) # return e + + return cat("return ", e) + +end + +procedure Rlit(e) + + return e + +end + +procedure Scan(e1, e2) # e1 ? e2 + + return cat("(", e1 , " ? ", e2, ")") + +end + +procedure Section(op, e1, e2, e3) # e1[e2 op e3] + + return cat(e1, "[", e2, op, e3, "]") + +end + +procedure Slit(s) # "s" + + return image(s) + +end + +procedure Static(ev[]) # static v1, v2, .. + local result + + result := "" + every result ||:= !ev || ", " + + write("static ", result[1:-2]) + + return + +end + +procedure Subscript(e1, e2) # e1[e2] + + return cat(e1, "[", e2, "]") + +end + +procedure Suspend(e) # suspend e + + return cat("suspend ", e) + +end + +procedure SuspendDo(e1, e2) # suspend e1 do e2 + + return cat("suspend ", e1, " do ", e2) + +end + +procedure To(e1, e2) # e1 to e2 + + return cat("(", e1, " to ", e2, ")") + +end + +procedure ToBy(e1, e2, e3) # e1 to e2 by e3 + + return cat("(", e1, " to ", e2, " by ", e3, ")") + +end + +procedure Repalt(e) # |e + + return cat("(|", e, ")") + +end + +procedure Unop(op, e) # op e + + return cat("(", op, e, ")") + +end + +procedure Until(e) # until e + + return cat("until ", e) + +end + +procedure UntilDo(e1, e2) # until e1 do e2 + + return cat("until ", e1, " do ", e2) + +end + +procedure Var(s) # v + + return s + +end + +procedure While(e) # while e + + return cat("while ", e) + +end + +procedure WhileDo(e1, e2) # while e1 do e2 + + return cat("while ", e1, " do ", e2) + +end diff --git a/ipl/procs/everycat.icn b/ipl/procs/everycat.icn new file mode 100644 index 0000000..1ecbe73 --- /dev/null +++ b/ipl/procs/everycat.icn @@ -0,0 +1,55 @@ +############################################################################ +# +# File: everycat.icn +# +# Subject: Procedure for generating all concatenations +# +# Author: Ralph E. Griswold +# +# Date: April 25, 1992 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# everycat(x1, x2, ...) generates the concatenation of every string +# from !x1, !x2, ... . +# +# For example, if +# +# first := ["Mary", "Joe", "Sandra"] +# last := ["Smith", "Roberts"] +# +# then +# +# every write(everycat(first, " ", last)) +# +# writes +# +# Mary Smith +# Mary Roberts +# Joe Smith +# Joe Roberts +# Sandra Smith +# Sandra Roberts +# +# Note that x1, x2, ... can be any values for which !x1, !x2, ... produce +# strings or values convertible to strings. In particular, in the example +# above, the second argument is a one-character string " ", so that !" " +# generates a single blank. +# +############################################################################ + +procedure everycat(args[]) + local arg + + arg := get(args) | fail + + if *args = 0 then + suspend !arg + else + suspend !arg || everycat ! args + +end diff --git a/ipl/procs/expander.icn b/ipl/procs/expander.icn new file mode 100644 index 0000000..e346029 --- /dev/null +++ b/ipl/procs/expander.icn @@ -0,0 +1,388 @@ +############################################################################ +# +# File: expander.icn +# +# Subject: Procedures to convert character pattern expressions +# +# Author: Ralph E. Griswold +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# pfl2str(pattern) expands pattern-form expressions, which have the form +# +# [<expr><op><expr>] +# +# to the corresponding string. +# +# The value of <op> determines the operation to be performed. +# +# pfl2gxp(pattern) expands pattern-form expressions into generators +# that, when compiled and evaluated, produce the corresponding +# string. +# +# pfl2pwl(pattern) converts pattern-form expressions to Painter's +# weaving language. +# +###########################################################################n +# +# Links: strings, weaving +# +############################################################################ + +link strings +link weaving + +procedure pfl2str(pattern) #: pattern-form to plain string + local result, expr1, expr2, op + static operator, optbl + + initial { + operator := '*-!|+,/~:?%<>#`' + + optbl := table() + + optbl["*"] := repl + optbl["<"] := Upto + optbl[">"] := Downto + optbl["-"] := UpDown + optbl["|"] := Palindrome +# optbl["!"] := Palindroid + optbl["+"] := Block + optbl["~"] := Interleave + optbl["->"] := Extend + optbl[":"] := Template + optbl["?"] := Permute + optbl["%"] := Pbox + optbl["<>"] := UpDown + optbl["><"] := DownUp + optbl["#"] := rotate + optbl["`"] := reverse + optbl[","] := proc("||", 2) + } + + result := "" + + pattern ? { + while result ||:= tab(upto('[')) do { + move(1) +# expr1 := pfl2str(tab(bal(operator, '[', ']'))) | return error("1", pattern) + expr1 := pfl2str(tab(bal(operator, '[', ']'))) | { + result ||:= pfl2str(tab(bal(']', '[', ']'))) + move(1) + next + } + op := tab(many(operator)) | return error("2", pattern) + expr2 := pfl2str(tab(bal(']', '[', ']'))) | return error("3", pattern) + result ||:= \optbl[op](expr1, expr2) | return error("4", pattern) + move(1) + } + if not pos(0) then result ||:= tab(0) + } + + return result + +end + +procedure pfl2pwl(pattern) #: pattern form to Painter expression + local result, i, j, slist, s, expr1, expr2, op, head + static operator, optbl + + initial { + operator := '*-!|+,;/~:?%<>#`' + + optbl := table() + + optbl["*"] := "*" + optbl["<"] := "<" + optbl[">"] := ">" + optbl["-"] := "-" + optbl["|"] := "|" + optbl["!"] := "!" # not supported in PWL + optbl["+"] := "[]" + optbl["->"] := "->" + optbl["~"] := "~" + optbl[":"] := ":" + optbl["?"] := " perm " + optbl["%"] := " pbox " + optbl["<>"] := "<>" + optbl["><"] := "><" + optbl["#"] := "#" + optbl["`"] := "`" + optbl[","] := "," + } + + result := "" + + pattern ? { + while head := tab(upto('[')) do { + if *head > 0 then result ||:= "," || head + move(1) + expr1 := pfl2pwl(tab(bal(operator, '[', ']'))) | return error() + op := tab(many(operator)) | return error() + expr2 := pfl2pwl(tab(bal(']', '[', ']'))) | return error() + result ||:= "," || "(" || expr1 || \optbl[op] || expr2 || ")" | + return error() + move(1) + } + if not pos(0) then result ||:= "," || tab(0) + } + + return result[2:0] + +end + +procedure error(expr1, expr2) + + write(&errout, "*** error ", expr1, " ", expr2) + + fail + +end + +procedure pfl2gxp(pattern, arg) #: pattern form to generating expression + local result, i, j, slist, s, expr1, expr2, op + static operator, optbl, argtbl + + initial { + + operator := ',.*-!|+;/~:?%<>#`' + + optbl := table() + + optbl["*"] := "Repl{" + optbl["<"] := "Upto{" + optbl[">"] := "Downto{" + optbl["-"] := "UpDownto{" + optbl["|"] := "TileMirror{" + optbl["!"] := "Palin{" + optbl["+"] := "Valrpt{" + optbl["~"] := "Inter{" + optbl["->"] := "ExtendSeq{" + optbl["~"] := "Parallel{" + optbl[":"] := "Template{" + optbl["?"] := "Permut{" + optbl["%"] := "Pbox{" + optbl["<>"] := "UpDown{" + optbl["><"] := "DownUp{" + optbl["#"] := "Rotate{" + optbl["`"] := "Reverse{" + optbl["*"] := repl + } + + /arg := str + + # Handling of literal arguments + + argtbl := table(str) + argtbl["*"] := 1 + argtbl["#"] := 1 + argtbl["->"] := 1 + + if /pattern | (*pattern = 0) then return image("") + + result := "" + + pattern ? { + while result ||:= arg(tab(upto('['))) do { + move(1) + expr1 := pfl2gxp(tab(bal(operator, '[', ']')), arg) | { + result ||:= tab(bal(']', '[', ']')) || " | " # no operator + move(1) + next + } + if ="." then result ||:= tab(bal(']', '[', ']')) || " | " + else { + op := tab(many(operator)) | return error() + expr2 := pfl2gxp(tab(bal(']', '[', ']')), argtbl[op]) | return error() + result ||:= \optbl[op] || expr1 || "," || expr2 || ") | " | + return error() + } + move(1) + } + if not pos(0) then result ||:= arg(tab(0)) + } + + return trim(result, '| ') + +end + +procedure lit(s) + + return "!" || image(s) + +end + +procedure str(s) + + return lit(s) || " | " + +end + +procedure galt(s) + + return "Galt{" || collate(s, repl(",", *s - 1)) || "}" + +end + +procedure pwl2pfl(wexpr) #: Painter expression to pattern form + + return pwlcvt(prepare(wexpr)) + +end + +procedure prepare(wexpr) # preprocess pwl + local inter, result + static names, names1 + + initial { + names := [ + "", # expression placeholder + " block ", "[]", + " repeat ", "*", + " rep ", "*", + " extend ", "==", + " ext ", "==", + " concat ", ",", + " interleave ", "~", + " int ", "~", + " upto ", ">", + " downto ", "<", + " template ", ":", + " temp ", ":", + " palindrome ", "|", + " pal ", "|", + " pal", "|", + " permute ", "?", + " perm ", "?", + " pbox ", "%", + " updown ", "<>", + " downup ", "><", + " rotate ", "#", + " rot ", "#", + " reverse ", "`", + " rev ", "`", + " rev", "`", + ] + + names1 := [ + "", # expression placeholder + "pal", "|", + "rev", "`" + ] + + } + + result := "" + + wexpr ? { + while result ||:= tab(upto('[')) do { + move(1) + inter := tab(bal(']')) + if *inter > 0 then result ||:= spray(inter) + else result ||:= "[]" + move(1) + } + result ||:= tab(0) + } + + if upto(result, ' ') then { + if upto(result, &letters) then { + names[1] := result + result := (replacem ! names) + } + } + + if upto(result, &letters) then { + names1[1] := result + result := (replacem ! names1) + } + + return deletec(map(result, "[]", "=="), ' ') + +end + +procedure pwlcvt(wexpr) + local result, inter + + wexpr ?:= { + 2(="(", tab(bal(')')), pos(-1)) + } + + result := "" + + wexpr ? { + while result ||:= form1(pwlcvt(tab(bal('|`', '([', ']('))), move(1)) + result ||:= tab(0) + } + + wexpr := result + result := "" + + wexpr ? { + while result ||:= form2(pwlcvt(tab(bal('->:#*=~', '([', ')]'))), + =("#" | "*" | "->" | "~" | ":" | "=="), pwlcvt(tab(0))) + result ||:= tab(0) + } + + wexpr := result + result := "" + + wexpr ? { + while result ||:= form2(pwlcvt(tab(bal('<>', '([', ')]'))), + =("><" | "<>"), pwlcvt(tab(0))) + result ||:= tab(0) + } + + wexpr := result + result := "" + + wexpr ? { + while result ||:= form2(pwlcvt(tab(bal('<->,', '([', ')]'))), + =(">" | "<" | "-" | ","), pwlcvt(tab(0))) + result ||:= tab(0) + } + + return result + +end + +procedure form1(wexpr, op) + + return "[" || wexpr || op || "]" + +end + +procedure form2(wexpr1, op, wexpr2) + + return "[" || wexpr1 || op || wexpr2 || "]" + +end + +procedure spray(inter) + local count, s1, s2, s3, colors + + s1 := s2 := s3 := "" + + inter ?:= { # only palindome and reflection allowed, it seems + 1(tab(upto('|`') | 0), s3 := tab(0)) + } + + inter ? { + while s1 ||:= colors := tab(upto(' ')) do { + tab(many(' ')) + count := tab(upto(' ') | 0) + if *count = 1 then s2 ||:= repl(count, *colors) + else s2 ||:= repl("{" || count || "}", *colors) + move(1) | break + } + } + + return "((" || s1 || s3 || ")" || "[]" || s2 || ")" + +end diff --git a/ipl/procs/exprfile.icn b/ipl/procs/exprfile.icn new file mode 100644 index 0000000..fb9db59 --- /dev/null +++ b/ipl/procs/exprfile.icn @@ -0,0 +1,134 @@ +############################################################################ +# +# File: exprfile.icn +# +# Subject: Procedures to produce programs on the fly +# +# Author: Ralph E. Griswold +# +# Date: August 5, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# exprfile(exp, link, ...) +# produces a pipe to a program that writes all the +# results generated by exp. The trailing arguments +# name link files needed for the expression. +# +# exprfile() closes any previous pipe it opened +# and deletes its temporary file. Therefore, +# exprfile() cannot be used for multiple expression +# pipes. +# +# If the expression fails to compile, the global +# expr_error is set to 1; otherwise 0. +# +# exec_expr(expr_list, links[]) +# generates the results of executing the expression +# contained in the lists expr_list with the specified +# links. +# +# plst2pstr(L) converts the list of Icon programs lines in L to a +# string with separating newlines. +# +# pstr2plst(s) converts the string of Icon program lines (separated +# by newlines) to a list of lines. +# +# ucode(file) produces a ucode file from the Icon program in file. +# +############################################################################ +# +# Requires: system(), pipes, /tmp +# +############################################################################ +# +# Links: io +# +############################################################################ + +link io + +global expr_error + +procedure exprfile(exp, links[]) #: pipe for Icon expression + local output + static name, input + + expr_error := &null + + remove(\name) # remove former executable + close(\input) # and close last pipe + + output := tempfile("expr", ".icn", "/tmp") + + image(output) ? { + ="file(" + name := tab(find(".icn")) + } + + write(output, "invocable all") + every write(output, "link ", image(!links)) + write(output, "procedure main(args)") + write(output, " every write(", exp, ")") + write(output, "end") + + close(output) + + if system("icont -o " || name || " -s " || name || + " >/dev/null 2>/dev/null") ~= 0 then { + expr_error := 1 + remove(name || ".icn") + fail + } + + remove(name || ".icn") # remove source code file + + # Return a pipe for the executable. Error messages are discarded. + + return input := open(name || " 2>/dev/null", "p") + +end + +procedure exec_expr(expr_list, links[]) #: execute expression in lists + + suspend !(exprfile ! push(links, plst2pstr(expr_list))) + +end + +procedure plst2pstr(L) #: convert program list to string + local result + + result := "" + + every result ||:= !L || "\n" + + return result + +end + +procedure pstr2plst(s) #: convert program string to list + local result + + result := [] + + s ? { + while put(result, tab(upto('\n'))) do + move(1) + if not pos(0) then put(result, tab(0)) + } + + return result + +end + +procedure ucode(file) #: create ucode file + + if system("icont -s -c " || file) ~= 0 then fail + + return + +end diff --git a/ipl/procs/factors.icn b/ipl/procs/factors.icn new file mode 100644 index 0000000..213e2f8 --- /dev/null +++ b/ipl/procs/factors.icn @@ -0,0 +1,319 @@ +############################################################################ +# +# File: factors.icn +# +# Subject: Procedures related to factors and prime numbers +# +# Authors: Ralph E. Griswold and Gregg M. Townsend +# +# Date: January 23, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This file contains procedures related to factorization and prime +# numbers. +# +# divisors(n) generates the divisors of n. +# +# divisorl(n) returns a list of the divisors of n. +# +# factorial(n) returns n!. It fails if n is less than 0. +# +# factors(i, j) returns a list containing the prime factors of i +# limited to maximum value j; default, no limit. +# +# genfactors(i, j) +# like factors(), except factors are generated as +# they are found. +# +# gfactorial(n, i) +# generalized factorial; n x (n - i) x (n - 2i) x ... +# +# ispower(i, j) succeeds and returns root if i is k^j +# +# isprime(n) succeeds if n is a prime. +# +# nxtprime(n) returns the next prime number beyond n. +# +# pfactors(i) returns a list containing the primes that divide i. +# +# prdecomp(i) returns a list of exponents for the prime +# decomposition of i. +# +# prime() generates the primes. +# +# primel() generates the primes from a precompiled list. +# +# primorial(i,j) product of primes j <= i; j defaults to 1. +# +# sfactors(i, j) as factors(i, j), except output is in string form +# with exponents for repeated factors +# +# squarefree(i) succeeds if the factors of i are distinct +# +############################################################################ +# +# Notes: Some of these procedures are not fast enough for extensive work. +# Factoring is believed to be a hard problem. factors() should only be +# used for small numbers. +# +############################################################################ +# +# Requires: Large-integer arithmetic; prime.lst for primel() and primorial(). +# +############################################################################ +# +# Links: io, numbers +# +############################################################################ + +link io +link numbers + +procedure divisors(n) #: generate the divisors of n + local d, dlist + + dlist := [] + every d := seq() do { + if d * d >= n then + break + if n % d = 0 then { + push(dlist, d) + suspend d + } + } + if d * d = n then + suspend d + suspend n / !dlist + +end + +procedure divisorl(n) #: return list of divisors of n + local divs + every put(divs := [], divisors(n)) + return divs +end + +procedure factorial(n) #: return n! (n factorial) + local i + + n := integer(n) | runerr(101, n) + + if n < 0 then fail + + i := 1 + + every i *:= 1 to n + + return i + +end + +procedure factors(i, j) #: return list of factors + local facts + + every put(facts := [], genfactors(i, j)) + return facts + +end + +procedure genfactors(i, j) #: generate prime factors of integer + local p + + i := integer(i) | runerr(101, i) + /j := i + + every p := prime() do { + if p > j | p * p > i then break + while i % p = 0 do { + suspend p + i /:= p + } + if i = 1 then break + } + if i > 1 then suspend i + +end + +procedure gfactorial(n, i) #: generalized factorial + local j + + n := integer(n) | runerr(101, n) + i := integer(i) | 1 + + if n < 0 then fail + if i < 1 then fail + + j := n + + while n > i do { + n -:= i + j *:= n + } + + return j + +end + +procedure pfactors(i) #: primes that divide integer + local facts, p + + i := integer(i) | runerr(101, i) + facts := [] + every p := prime() do { + if p > i then break + if i % p = 0 then { + put(facts, p) + while i % p = 0 do + i /:= p + } + } + + return facts + +end + +procedure ispower(i, j) #: test for integer power + local k, n + + k := (n := round(i ^ (1.0 / j))) ^ j + if k = i then return n else fail + +end + +# NOTE: The following method for testing primality, called Baby Division, +# is about the worst possible. It is inappropriate for all but small +# numbers. + +procedure isprime(n) #: test for primality + local p + + n := integer(n) | runerr(101, n) + if n <= 1 then fail # 1 is not a prime + every p := prime() do { + if p * p > n then return n + if n % p = 0 then fail + } + +end + +procedure nxtprime(n) #: next prime beyond n + local d + static step, div + + initial { + step := [1,6,5,4,3,2,1,4,3,2,1,2,1,4,3,2,1,2,1,4,3,2,1,6,5,4,3,2,1,2] + div := [7] # list of known primes + } + + n := integer(n) | runerr(101, n) + if n < 7 then # handle small primes specially + return n < (2 | 3 | 5 | 7) + + repeat { + n +:= step[n % 30 + 1] # step past multiples of 2, 3, 5 + every (d := !div) | |put(div, d := nxtprime(d)) do { # get test divisors + if n % d = 0 then # if composite, try a larger candidate + break + if d * d > n then # if not divisible up to sqrt, is prime + return n + } + } + +end + +procedure prdecomp(i) #: prime decomposition + local decomp, count, p + + decomp := [] + every p := prime() do { + count := 0 + while i % p = 0 do { + count +:= 1 + i /:= p + } + put(decomp, count) + if i = 1 then break + } + + return decomp + +end + +procedure prime() #: generate primes + local i, k + + suspend 2 | ((i := seq(3, 2)) & (not(i = (k := (3 to sqrt(i) by 2)) * + (i / k))) & i) + +end + +procedure primel() #: primes from list + local pfile + + pfile := dopen("primes.lst") | stop("*** cannot open primes.lst") + + suspend !pfile + +end + +procedure primorial(i, j) #: product of primes + local m, k, mark + + /j := 1 + + m := 1 + mark := &null # to check for completeness + + every k := primel() do { # limited by prime list + if k <= j then next + if k <= i then m *:= k + else { + mark := 1 + break + } + } + + if \mark then return m else fail # fail if list is too short + +end + +procedure sfactors(i, j) #: return factors in string form + local facts, result, term, nterm, count + + facts := factors(i, j) + + result := "" + + term := get(facts) # will be at least one + count := 1 + + while nterm := get(facts) do { + if term = nterm then count +:= 1 + else { + if count > 1 then result ||:= " " || term || "^" || count + else result ||:= " " || term + count := 1 + term := nterm + } + } + + if count > 1 then result ||:= " " || term || "^" || count + else result ||:= " " || term + + return result[2:0] + +end + +procedure squarefree(n) #: test for square-free number + local facts + + facts := factors(n) + + if *facts = *set(facts) then return n else fail + +end diff --git a/ipl/procs/fastfncs.icn b/ipl/procs/fastfncs.icn new file mode 100644 index 0000000..12a9d2f --- /dev/null +++ b/ipl/procs/fastfncs.icn @@ -0,0 +1,67 @@ +############################################################################ +# +# File: fastfncs.icn +# +# Subject: Procedures for integer functions using fastest method +# +# Author: Ralph E. Griswold +# +# Date: December 26, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures implement integer-valued using the fastest +# method known to the author. "Fastest" does not mean "fast". +# +# acker(i, j) Ackermann's function +# fib(i) Fibonacci sequence +# g(k, i) Generalized Hofstader nested recurrence +# q(i) "Chaotic" sequence +# robbins(i) Robbins numbers +# +############################################################################ +# +# See also: iterfncs.icn, memrfncs.icn, recrfncs.icn +# +############################################################################ +# +# Links: factors, memrfncs +# +############################################################################ + +link factors +link memrfncs + +procedure g(k, n) + local value + static psi + + initial psi := 1.0 / &phi + + if n = 0 then return 0 + + value := 0 + + value +:= floor(psi * floor((seq(0) \ k + n) / real(k)) + psi) + + return value + +end + +procedure robbins(n) + local numer, denom, i + + numer := denom := 1 + + every i := 0 to n - 1 do { + numer *:= factorial(3 * i + 1) + denom *:= factorial(n + i) + } + + return numer / denom + +end diff --git a/ipl/procs/feval.icn b/ipl/procs/feval.icn new file mode 100644 index 0000000..2d84dad --- /dev/null +++ b/ipl/procs/feval.icn @@ -0,0 +1,54 @@ +############################################################################ +# +# File: feval.icn +# +# Subject: Procedure to evaluate string as function call +# +# Author: Ralph E. Griswold +# +# Date: June 8, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure analyzes a string representing an Icon function or +# procedure call and evaluates the result. +# +# It assumes the string is well-formed. The arguments can only be +# Icon literals. Escapes, commas, and parentheses in strings literals +# are not handled. +# +############################################################################ +# +# Links: ivalue +# +############################################################################ + +invocable all + +link ivalue + +procedure feval(s) + local fnc, argl + + s ? { + fnc := tab(upto('(')) | { + write(&errout, "*** syntax error") + fail + } + fnc := proc(fnc, 3 to 1 by -1) | { + write(&errout, "*** invalid function or operation") + fail + } + move(1) + + argl := [] + while put(argl, ivalue(tab(upto(',)')))) do move(1) + + suspend fnc ! argl + } + +end diff --git a/ipl/procs/filedim.icn b/ipl/procs/filedim.icn new file mode 100644 index 0000000..561e347 --- /dev/null +++ b/ipl/procs/filedim.icn @@ -0,0 +1,45 @@ +############################################################################ +# +# File: filedim.icn +# +# Subject: Procedure to compute file dimensions +# +# Author: Ralph E. Griswold +# +# Date: April 30, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# filedim(s, p) computes the number of rows and maximum column width +# of the file named s. The procedure p, which defaults to detab, i +# applied to each line. For example, to have lines left as is, use +# +# filedim(s, 1) +# +############################################################################ + +record textdim(cols, rows) + +procedure filedim(s, p) + local input, rows, cols, line + + /p := detab + + input := open(s) | stop("*** cannot open ", s) + + rows := cols := 0 + + while line := p(read(input)) do { + rows +:= 1 + cols <:= *line + } + + close(input) + + return textdim(cols, rows) + +end diff --git a/ipl/procs/filenseq.icn b/ipl/procs/filenseq.icn new file mode 100644 index 0000000..873e062 --- /dev/null +++ b/ipl/procs/filenseq.icn @@ -0,0 +1,56 @@ +############################################################################ +# +# File: filenseq.icn +# +# Subject: Procedure to get highest numbered filename in a sequence +# +# Author: David A. Gamey +# +# Date: May 2, 2001 +# +########################################################################### +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure is useful when you need to create the next file +# in a series of files (such as successive log files). +# +# Usage: +# +# fn := nextseqfilename( ".", "$", "log") +# +# returns the (non-existent) filename next in the sequence .\$*.log +# (where the * represents 1, 2, 3, ...) or fails +# +# +############################################################################ +# +# Requires: MS-DOS or another congenial operating system +# +############################################################################ +# +# Links: io +# +############################################################################ + +link io + +procedure nextseqfilename(dir,pre,ext) + +local s,f,n,wn + +static wf +initial wf := 8 # filename width + +dir ||:= ( dir[-1] ~== "\\" ) + +s := set( dosdirlist( dir, pre || "*." || ext || " /a:-d" ) ) + +n := integer( repl( '9', wn := wf - *pre ) ) + +every f := map( dir || pre || right( 1 to n, wn,"0") || "." || ext ) do + if not member(s,f) then return f + +end diff --git a/ipl/procs/filesize.icn b/ipl/procs/filesize.icn new file mode 100644 index 0000000..9aca124 --- /dev/null +++ b/ipl/procs/filesize.icn @@ -0,0 +1,35 @@ +############################################################################ +# +# File: filesize.icn +# +# Subject: Procedure to get the size of a file +# +# Author: Ralph E. Griswold +# +# Date: July 9, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# filesize(s) returns the number of characters in the file named s; it +# fails if s cannot be opened. +# +############################################################################ + +procedure filesize(s) #: file size + local input, size + + input := open(s) | fail + + size := 0 + + while size +:= *reads(input, 10000) + + close(input) + + return size + +end diff --git a/ipl/procs/findre.icn b/ipl/procs/findre.icn new file mode 100644 index 0000000..85abc30 --- /dev/null +++ b/ipl/procs/findre.icn @@ -0,0 +1,737 @@ +############################################################################ +# +# File: findre.icn +# +# Subject: Procedure to find regular expression +# +# Author: Richard L. Goerwitz +# +# Date: March 3, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.17 +# +############################################################################ +# +# DESCRIPTION: findre() is like the Icon builtin function find(), +# except that it takes, as its first argument, a regular expression +# pretty much like the ones the Unix egrep command uses (the few +# minor differences are listed below). Its syntax is the same as +# find's (i.e. findre(s1,s2,i,j)), with the exception that a no- +# argument invocation wipes out all static structures utilized by +# findre, and then forces a garbage collection. +# +############################################################################ +# +# (For those not familiar with regular expressions and the Unix egrep +# command: findre() offers a simple and compact wildcard-based search +# system. If you do a lot of searches through text files, or write +# programs which do searches based on user input, then findre is a +# utility you might want to look over.) +# +# IMPORTANT DIFFERENCES between find and findre: As noted above, +# findre() is just a find() function that takes a regular expression +# as its first argument. One major problem with this setup is that +# it leaves the user with no easy way to tab past a matched +# substring, as with +# +# s ? write(tab(find("hello")+5)) +# +# In order to remedy this intrinsic deficiency, findre() sets the +# global variable __endpoint to the first position after any given +# match occurs. Use this variable with great care, preferably +# assigning its value to some other variable immediately after the +# match (for example, findre("hello [.?!]*",s) & tmp := __endpoint). +# Otherwise, you will certainly run into trouble. (See the example +# below for an illustration of how __endpoint is used). +# +# IMPORTANT DIFFERENCES between egrep and findre: findre utilizes +# the same basic language as egrep. The only big difference is that +# findre uses intrinsic Icon data structures and escaping conven- +# tions rather than those of any particular Unix variant. Be care- +# ful! If you put findre("\(hello\)",s) into your source file, +# findre will treat it just like findre("(hello)",s). If, however, +# you enter '\(hello\)' at run-time (via, say, findre(!&input,s)), +# what Icon receives will depend on your operating system (most +# likely, a trace will show "\\(hello\\)"). +# +############################################################################ +# +# BUGS: Space has essentially been conserved at the expense of time +# in the automata produced by findre(). The algorithm, in other +# words, will produce the equivalent of a pushdown automaton under +# certain circumstances, rather than strive (at the expense of space) +# for full determinism. I tried to make up a nfa -> dfa converter +# that would only create that portion of the dfa it needed to accept +# or reject a string, but the resulting automaton was actually quite +# slow (if anyone can think of a way to do this in Icon, and keep it +# small and fast, please let us all know about it). Note that under +# version 8 of Icon, findre takes up negligible storage space, due to +# the much improved hashing algorithm. I have not tested it under +# version 7, but I would expect it to use up quite a bit more space +# in that environment. +# +# IMPORTANT NOTE: Findre takes a shortest-possible-match approach +# to regular expressions. In other words, if you look for "a*", +# findre will not even bother looking for an "a." It will just match +# the empty string. Without this feature, findre would perform a bit +# more slowly. The problem with such an approach is that often the +# user will want to tab past the longest possible string of matched +# characters (say tab((findre("a*|b*"), __endpoint)). In circumstan- +# ces like this, please just use something like: +# +# s ? { +# tab(find("a")) & # or use Arb() from the IPL (patterns.icn) +# tab(many('a')) +# tab(many('b')) +# } +# +# or else use some combination of findre and the above. +# +############################################################################ +# +# REGULAR EXPRESSION SYNTAX: Regular expression syntax is complex, +# and yet simple. It is simple in the sense that most of its power +# is concentrated in about a dozen easy-to-learn symbols. It is +# complex in the sense that, by combining these symbols with +# characters, you can represent very intricate patterns. +# +# I make no pretense here of offering a full explanation of regular +# expressions, their usage, and the deeper nuances of their syntax. +# As noted above, this should be gleaned from a Unix manual. For +# quick reference, however, I have included a brief summary of all +# the special symbols used, accompanied by an explanation of what +# they mean, and, in some cases, of how they are used (most of this +# is taken from the comments prepended to Jerry Nowlin's Icon-grep +# command, as posted a couple of years ago): +# +# ^ - matches if the following pattern is at the beginning +# of a line (i.e. ^# matches lines beginning with "#") +# $ - matches if the preceding pattern is at the end of a line +# . - matches any single character +# + - matches from 1 to any number of occurrences of the +# previous expression (i.e. a character, or set of paren- +# thesized/bracketed characters) +# * - matches from 0 to any number of occurrences of the previous +# expression +# \ - removes the special meaning of any special characters +# recognized by this program (i.e if you want to match lines +# beginning with a "[", write ^\[, and not ^[) +# | - matches either the pattern before it, or the one after +# it (i.e. abc|cde matches either abc or cde) +# [] - matches any member of the enclosed character set, or, +# if ^ is the first character, any nonmember of the +# enclosed character set (i.e. [^ab] matches any character +# _except_ a and b). +# () - used for grouping (e.g. ^(abc|cde)$ matches lines consist- +# ing of either "abc" or "cde," while ^abc|cde$ matches +# lines either beginning with "abc" or ending in "cde") +# +############################################################################ +# +# EXAMPLE program: +# +# procedure main(a) +# while line := !&input do { +# token_list := tokenize_line(line,a[1]) +# every write(!token_list) +# } +# end +# +# procedure tokenize_line(s,sep) +# tmp_lst := [] +# s ? { +# while field := tab(findre(sep)|0) & +# mark := __endpoint +# do { +# put(tmp_lst,"" ~== field) +# if pos(0) then break +# else tab(mark) +# } +# } +# return tmp_lst +# end +# +# The above program would be compiled with findre (e.g. "icont +# test_prg.icn findre.icn") to produce a single executable which +# tokenizes each line of input based on a user-specified delimiter. +# Note how __endpoint is set soon after findre() succeeds. Note +# also how empty fields are excluded with "" ~==, etc. Finally, note +# that the temporary list, tmp_lst, is not needed. It is included +# here merely to illustrate one way in which tokens might be stored. +# +# Tokenizing is, of course, only one of many uses one might put +# findre to. It is very helpful in allowing the user to construct +# automata at run-time. If, say, you want to write a program that +# searches text files for patterns given by the user, findre would be +# a perfect utility to use. Findre in general permits more compact +# expression of patterns than one can obtain using intrinsic Icon +# scanning facilities. Its near complete compatibility with the Unix +# regexp library, moreover, makes for greater ease of porting, +# especially in cases where Icon is being used to prototype C code. +# +############################################################################ + + +global state_table, parends_present, slash_present +global biggest_nonmeta_str, __endpoint +record o_a_s(op,arg,state) + + +procedure findre(re, s, i, j) + + local p, default_val, x, nonmeta_len, tokenized_re, tmp + static FSTN_table, STRING_table + initial { + FSTN_table := table() + STRING_table := table() + } + + if /re then { + FSTN_table := table() + STRING_table := table() + collect() # do it *now* + return + } + + if /s := &subject + then default_val := &pos + else default_val := 1 + + if \i then { + if i < 1 then + i := *s + (i+1) + } + else i := default_val + + if \j then { + if j < 1 then + j := *s + (j+1) + } + else j := *s+1 + + if /FSTN_table[re] then { + # If we haven't seen this re before, then... + if \STRING_table[re] then { + # ...if it's in the STRING_table, use plain find() + every p := find(STRING_table[re],s,i,j) + do { __endpoint := p + *STRING_table[re]; suspend p } + fail + } + else { + # However, if it's not in the string table, we have to + # tokenize it and check for metacharacters. If it has + # metas, we create an FSTN, and put that into FSTN_table; + # otherwise, we just put it into the STRING_table. + tokenized_re := tokenize(re) + if 0 > !tokenized_re then { + # if at least one element is < 0, re has metas + MakeFSTN(tokenized_re) | err_out(re,2) + # both biggest_nonmeta_str and state_table are global + /FSTN_table[re] := [.biggest_nonmeta_str, copy(state_table)] + } + else { + # re has no metas; put the input string into STRING_table + # for future reference, and execute find() at once + tmp := ""; every tmp ||:= char(!tokenized_re) + insert(STRING_table,re,tmp) + every p := find(STRING_table[re],s,i,j) + do { __endpoint := p + *STRING_table[re]; suspend p } + fail + } + } + } + + + if nonmeta_len := (1 < *FSTN_table[re][1]) then { + # If the biggest non-meta string in the original re + # was more than 1, then put in a check for it... + s[1:j] ? { + tab(x := i to j - nonmeta_len) & + (find(FSTN_table[re][1]) | fail) \ 1 & + (__endpoint := apply_FSTN(&null,FSTN_table[re][2])) & + (suspend x) + } + } + else { + #...otherwise it's not worth worrying about the biggest nonmeta str + s[1:j] ? { + tab(x := i to j) & + (__endpoint := apply_FSTN(&null,FSTN_table[re][2])) & + (suspend x) + } + } + +end + + + +procedure apply_FSTN(ini,tbl) + + local biggest_pos, POS, tmp, fin + static s_tbl + + /ini := 1 & s_tbl := tbl & biggest_pos := 1 + if ini = 0 then { + return &pos + } + POS := &pos + fin := 0 + + repeat { + if tmp := !s_tbl[ini] & + tab(tmp.op(tmp.arg)) + then { + if tmp.state = fin + then return &pos + else ini := tmp.state + } + else (&pos := POS, fail) + } + +end + + + +procedure tokenize(s) + + local token_list, chr, tmp, b_loc, next_one, fixed_length_token_list, i + + token_list := list() + s ? { + tab(many('*+?|')) + while chr := move(1) do { + if chr == "\\" + # it can't be a metacharacter; remove the \ and "put" + # the integer value of the next chr into token_list + then put(token_list,ord(move(1))) | err_out(s,2,chr) + else if any('*+()|?.$^',chr) + then { + # Yuck! Egrep compatibility stuff. + case chr of { + "*" : { + tab(many('*+?')) + put(token_list,-ord("*")) + } + "+" : { + tmp := tab(many('*?+')) | &null + if upto('*?',\tmp) + then put(token_list,-ord("*")) + else put(token_list,-ord("+")) + } + "?" : { + tmp := tab(many('*?+')) | &null + if upto('*+',\tmp) + then put(token_list,-ord("*")) + else put(token_list,-ord("?")) + } + "(" : { + tab(many('*+?')) + put(token_list,-ord("(")) + } + default: { + put(token_list,-ord(chr)) + } + } + } + else { + case chr of { + # More egrep compatibility stuff. + "[" : { + b_loc := find("[") | *&subject+1 + every next_one := find("]",,,b_loc) + \next_one ~= &pos | err_out(s,2,chr) + put(token_list,-ord(chr)) + } + "]" : { + if &pos = (\next_one+1) + then put(token_list,-ord(chr)) & + next_one := &null + else put(token_list,ord(chr)) + } + default: put(token_list,ord(chr)) + } + } + } + } + + token_list := UnMetaBrackets(token_list) + + fixed_length_token_list := list(*token_list) + every i := 1 to *token_list + do fixed_length_token_list[i] := token_list[i] + return fixed_length_token_list + +end + + + +procedure UnMetaBrackets(l) + + # Since brackets delineate a cset, it doesn't make + # any sense to have metacharacters inside of them. + # UnMetaBrackets makes sure there are no metacharac- + # ters inside of the braces. + + local tmplst, i, Lb, Rb + + tmplst := list(); i := 0 + Lb := -ord("[") + Rb := -ord("]") + + while (i +:= 1) <= *l do { + if l[i] = Lb then { + put(tmplst,l[i]) + until l[i +:= 1] = Rb + do put(tmplst,abs(l[i])) + put(tmplst,l[i]) + } + else put(tmplst,l[i]) + } + return tmplst + +end + + + +procedure MakeFSTN(l,INI,FIN) + + # MakeFSTN recursively descends through the tree structure + # implied by the tokenized string, l, recording in (global) + # fstn_table a list of operations to be performed, and the + # initial and final states which apply to them. + + local i, inter, inter2, tmp, Op, Arg + static Lp, Rp, Sl, Lb, Rb, Caret_inside, Dot, Dollar, Caret_outside + # global biggest_nonmeta_str, slash_present, parends_present + initial { + Lp := -ord("("); Rp := -ord(")") + Sl := -ord("|") + Lb := -ord("["); Rb := -ord("]"); Caret_inside := ord("^") + Dot := -ord("."); Dollar := -ord("$"); Caret_outside := -ord("^") + } + + /INI := 1 & state_table := table() & + NextState("new") & biggest_nonmeta_str := "" + /FIN := 0 + + # I haven't bothered to test for empty lists everywhere. + if *l = 0 then { + /state_table[INI] := [] + put(state_table[INI],o_a_s(zSucceed,&null,FIN)) + return + } + + # HUNT DOWN THE SLASH (ALTERNATION OPERATOR) + every i := 1 to *l do { + if l[i] = Sl & tab_bal(l,Lp,Rp) = i then { + if i = 1 then err_out(l,2,char(abs(l[i]))) else { + /slash_present := "yes" + inter := NextState() + inter2:= NextState() + MakeFSTN(l[1:i],inter2,FIN) + MakeFSTN(l[i+1:0],inter,FIN) + /state_table[INI] := [] + put(state_table[INI],o_a_s(apply_FSTN,inter2,0)) + put(state_table[INI],o_a_s(apply_FSTN,inter,0)) + return + } + } + } + + # HUNT DOWN PARENTHESES + if l[1] = Lp then { + i := tab_bal(l,Lp,Rp) | err_out(l,2,"(") + inter := NextState() + if any('*+?',char(abs(0 > l[i+1]))) then { + case l[i+1] of { + -ord("*") : { + /state_table[INI] := [] + put(state_table[INI],o_a_s(apply_FSTN,inter,0)) + MakeFSTN(l[2:i],INI,INI) + MakeFSTN(l[i+2:0],inter,FIN) + return + } + -ord("+") : { + inter2 := NextState() + /state_table[inter2] := [] + MakeFSTN(l[2:i],INI,inter2) + put(state_table[inter2],o_a_s(apply_FSTN,inter,0)) + MakeFSTN(l[2:i],inter2,inter2) + MakeFSTN(l[i+2:0],inter,FIN) + return + } + -ord("?") : { + /state_table[INI] := [] + put(state_table[INI],o_a_s(apply_FSTN,inter,0)) + MakeFSTN(l[2:i],INI,inter) + MakeFSTN(l[i+2:0],inter,FIN) + return + } + } + } + else { + MakeFSTN(l[2:i],INI,inter) + MakeFSTN(l[i+1:0],inter,FIN) + return + } + } + else { # I.E. l[1] NOT = Lp (left parenthesis as -ord("(")) + every i := 1 to *l do { + case l[i] of { + Lp : { + inter := NextState() + MakeFSTN(l[1:i],INI,inter) + /parends_present := "yes" + MakeFSTN(l[i:0],inter,FIN) + return + } + Rp : err_out(l,2,")") + } + } + } + + # NOW, HUNT DOWN BRACKETS + if l[1] = Lb then { + i := tab_bal(l,Lb,Rb) | err_out(l,2,"[") + inter := NextState() + tmp := ""; every tmp ||:= char(l[2 to i-1]) + if Caret_inside = l[2] + then tmp := ~cset(Expand(tmp[2:0])) + else tmp := cset(Expand(tmp)) + if any('*+?',char(abs(0 > l[i+1]))) then { + case l[i+1] of { + -ord("*") : { + /state_table[INI] := [] + put(state_table[INI],o_a_s(apply_FSTN,inter,0)) + put(state_table[INI],o_a_s(any,tmp,INI)) + MakeFSTN(l[i+2:0],inter,FIN) + return + } + -ord("+") : { + inter2 := NextState() + /state_table[INI] := [] + put(state_table[INI],o_a_s(any,tmp,inter2)) + /state_table[inter2] := [] + put(state_table[inter2],o_a_s(apply_FSTN,inter,0)) + put(state_table[inter2],o_a_s(any,tmp,inter2)) + MakeFSTN(l[i+2:0],inter,FIN) + return + } + -ord("?") : { + /state_table[INI] := [] + put(state_table[INI],o_a_s(apply_FSTN,inter,0)) + put(state_table[INI],o_a_s(any,tmp,inter)) + MakeFSTN(l[i+2:0],inter,FIN) + return + } + } + } + else { + /state_table[INI] := [] + put(state_table[INI],o_a_s(any,tmp,inter)) + MakeFSTN(l[i+1:0],inter,FIN) + return + } + } + else { # I.E. l[1] not = Lb + every i := 1 to *l do { + case l[i] of { + Lb : { + inter := NextState() + MakeFSTN(l[1:i],INI,inter) + MakeFSTN(l[i:0],inter,FIN) + return + } + Rb : err_out(l,2,"]") + } + } + } + + # FIND INITIAL SEQUENCES OF POSITIVE INTEGERS, CONCATENATE THEM + if i := match_positive_ints(l) then { + inter := NextState() + tmp := Ints2String(l[1:i]) + # if a slash has been encountered already, forget optimizing + # in this way; if parends are present, too, then forget it, + # unless we are at the beginning or end of the input string + if INI = 1 | FIN = 2 | /parends_present & + /slash_present & *tmp > *biggest_nonmeta_str + then biggest_nonmeta_str := tmp + /state_table[INI] := [] + put(state_table[INI],o_a_s(match,tmp,inter)) + MakeFSTN(l[i:0],inter,FIN) + return + } + + # OKAY, CLEAN UP ALL THE JUNK THAT'S LEFT + i := 0 + while (i +:= 1) <= *l do { + case l[i] of { + Dot : { Op := any; Arg := &cset } + Dollar : { Op := pos; Arg := 0 } + Caret_outside: { Op := pos; Arg := 1 } + default : { Op := match; Arg := char(0 < l[i]) } + } | err_out(l,2,char(abs(l[i]))) + inter := NextState() + if any('*+?',char(abs(0 > l[i+1]))) then { + case l[i+1] of { + -ord("*") : { + /state_table[INI] := [] + put(state_table[INI],o_a_s(apply_FSTN,inter,0)) + put(state_table[INI],o_a_s(Op,Arg,INI)) + MakeFSTN(l[i+2:0],inter,FIN) + return + } + -ord("+") : { + inter2 := NextState() + /state_table[INI] := [] + put(state_table[INI],o_a_s(Op,Arg,inter2)) + /state_table[inter2] := [] + put(state_table[inter2],o_a_s(apply_FSTN,inter,0)) + put(state_table[inter2],o_a_s(Op,Arg,inter2)) + MakeFSTN(l[i+2:0],inter,FIN) + return + } + -ord("?") : { + /state_table[INI] := [] + put(state_table[INI],o_a_s(apply_FSTN,inter,0)) + put(state_table[INI],o_a_s(Op,Arg,inter)) + MakeFSTN(l[i+2:0],inter,FIN) + return + } + } + } + else { + /state_table[INI] := [] + put(state_table[INI],o_a_s(Op,Arg,inter)) + MakeFSTN(l[i+1:0],inter,FIN) + return + } + } + + # WE SHOULD NOW BE DONE INSERTING EVERYTHING INTO state_table + # IF WE GET TO HERE, WE'VE PARSED INCORRECTLY! + err_out(l,4) + +end + + + +procedure NextState(new) + static nextstate + if \new then nextstate := 1 + else nextstate +:= 1 + return nextstate +end + + + +procedure err_out(x,i,elem) + writes(&errout,"Error number ",i," parsing ",image(x)," at ") + if \elem + then write(&errout,image(elem),".") + else write(&errout,"(?).") + exit(i) +end + + + +procedure zSucceed() + return .&pos +end + + + +procedure Expand(s) + + local s2, c1, c2 + + s2 := "" + s ? { + s2 ||:= ="^" + s2 ||:= ="-" + while s2 ||:= tab(find("-")-1) do { + if (c1 := move(1), ="-", + c2 := move(1), + c1 << c2) + then every s2 ||:= char(ord(c1) to ord(c2)) + else s2 ||:= 1(move(2), not(pos(0))) | err_out(s,2,"-") + } + s2 ||:= tab(0) + } + return s2 + +end + + + +procedure tab_bal(l,i1,i2) + + local i, i1_count, i2_count + + i := 0 + i1_count := 0; i2_count := 0 + while (i +:= 1) <= *l do { + case l[i] of { + i1 : i1_count +:= 1 + i2 : i2_count +:= 1 + } + if i1_count = i2_count + then suspend i + } + +end + + +procedure match_positive_ints(l) + + # Matches the longest sequence of positive integers in l, + # beginning at l[1], which neither contains, nor is fol- + # lowed by a negative integer. Returns the first position + # after the match. Hence, given [55, 55, 55, -42, 55], + # match_positive_ints will return 3. [55, -42] will cause + # it to fail rather than return 1 (NOTE WELL!). + + local i + + every i := 1 to *l do { + if l[i] < 0 + then return (3 < i) - 1 | fail + } + return *l + 1 + +end + + +procedure Ints2String(l) + + local tmp + + tmp := "" + every tmp ||:= char(!l) + return tmp + +end + + +procedure StripChar(s,s2) + + local tmp + + if find(s2,s) then { + tmp := "" + s ? { + while tmp ||:= tab(find("s2")) + do tab(many(cset(s2))) + tmp ||:= tab(0) + } + } + return \tmp | s + +end diff --git a/ipl/procs/ftype.icn b/ipl/procs/ftype.icn new file mode 100644 index 0000000..73ad198 --- /dev/null +++ b/ipl/procs/ftype.icn @@ -0,0 +1,33 @@ +############################################################################ +# +# File: ftype.icn +# +# Subject: Procedure to produce type for file +# +# Author: Ralph E. Griswold +# +# Date: March 10, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure returns the file identification produced by file(1). +# +############################################################################ +# +# Requires: UNIX +# +############################################################################ + +procedure ftype(file) + + read(open("file " || file, "p")) ? { + tab(upto('\t')) + tab(many('\t')) + return tab(0) + } + +end diff --git a/ipl/procs/fullimag.icn b/ipl/procs/fullimag.icn new file mode 100644 index 0000000..6ebdaa7 --- /dev/null +++ b/ipl/procs/fullimag.icn @@ -0,0 +1,123 @@ +############################################################################ +# +# File: fullimag.icn +# +# Subject: Procedures to produce complete image of structured data +# +# Author: Robert J. Alexander +# +# Date: May 23, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# fullimage() -- enhanced image()-type procedure that outputs all data +# contained in structured types. The "level" argument tells it how far +# to descend into nested structures (defaults to unlimited). +# +############################################################################ + +global fullimage_level,fullimage_maxlevel,fullimage_done,fullimage_used, + fullimage_indent + +procedure fullimage(x,indent,maxlevel) + local tr,s,t + # + # Initialize + # + tr := &trace ; &trace := 0 # turn off trace till we're done + fullimage_level := 1 + fullimage_indent := indent + fullimage_maxlevel := \maxlevel | 0 + fullimage_done := table() + fullimage_used := set() + # + # Call fullimage_() to do the work. + # + s := fullimage_(x) + # + # Remove unreferenced tags from the result string, and even + # renumber them. + # + fullimage_done := table() + s ? { + s := "" + while s ||:= tab(upto('\'"<')) do { + case t := move(1) of { + "\"" | "'": { + s ||:= t + while (s ||:= tab(find(t) + 1)) \ 1 & s[-2] ~== "\\" + } + "<": { + t := +tab(find(">")) & move(1) + if member(fullimage_used,t) then { + /fullimage_done[t] := *fullimage_done + 1 + s ||:= "<" || fullimage_done[t] || ">" + } + } + } + } + s ||:= tab(0) + } + # + # Clean up and return. + # + fullimage_done := fullimage_used := &null # remove structures + &trace := tr # restore &trace + return s +end + + +procedure fullimage_(x,noindent) + local s,t,tr + t := type(x) + s := case t of { + "null" | "string" | "integer" | "real" | "co-expression" | "cset" | + "file" | "window" | "procedure" | "external": image(x) + default: fullimage_structure(x) + } + # + # Return the result. + # + return ( + if \fullimage_indent & not \noindent then + "\n" || repl(fullimage_indent,fullimage_level - 1) || s + else + s + ) +end + +procedure fullimage_structure(x) + local sep,s,t,tag,y + # + # If this structure has already been output, just output its tag. + # + if \(tag := fullimage_done[x]) then { + insert(fullimage_used,tag) + return "<" || tag || ">" + } + # + # If we've reached the max level, just output a normal image + # enclosed in braces to indicate end of the line. + # + if fullimage_level = fullimage_maxlevel then + return "{" || image(x) || "}" + # + # Output the structure in a style indicative of its type. + # + fullimage_level +:= 1 + fullimage_done[x] := tag := *fullimage_done + 1 + if (t := type(x)) == ("table" | "set") then x := sort(x) + s := "<" || tag || ">" || if t == "list" then "[" else t || "(" + sep := "" + if t == "table" then every y := !x do { + s ||:= sep || fullimage_(y[1]) || "->" || fullimage_(y[2],"noindent") + sep := "," + } + else every s ||:= sep || fullimage_(!x) do sep := "," + fullimage_level -:= 1 + return s || if t == "list" then "]" else ")" +end diff --git a/ipl/procs/gauss.icn b/ipl/procs/gauss.icn new file mode 100644 index 0000000..92334b2 --- /dev/null +++ b/ipl/procs/gauss.icn @@ -0,0 +1,44 @@ +############################################################################ +# +# File: gauss.icn +# +# Subject: Procedures to compute Gaussian distributions +# +# Author: Stephen B. Wampler +# +# Date: September 19, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# gauss_random(x, f) produces a Gaussian distribution about the value x. +# The value of f can be used to alter the shape of the Gaussian +# distribution (larger values flatten the curve...) +# +############################################################################ + +procedure gauss_random(x, f) + + /f := 1.0 # if f not passed in, default to 1.0 + + return gauss() * f + x + +end + +# Produce a random value within a Gaussian distribution +# about 0.0. (Sum 12 random numbers between 0 and 1, +# (expected mean is 6.0) and subtract 6 to center on 0.0 + +procedure gauss() + local v + + v := 0.0 + + every 1 to 12 do v +:= ?0 + + return v - 6.0 + +end diff --git a/ipl/procs/gdl.icn b/ipl/procs/gdl.icn new file mode 100644 index 0000000..57aa0e8 --- /dev/null +++ b/ipl/procs/gdl.icn @@ -0,0 +1,143 @@ +############################################################################ +# +# File: gdl.icn +# +# Subject: Procedures to get directory lists +# +# Author: Richard L. Goerwitz +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.3 +# +############################################################################ +# +# Gdl returns a list containing everything in a directory (whose name +# must be passed as an argument to gdl). Nothing fancy. I use this file +# as a template, modifying the procedures according to the needs of the +# program in which they are used. +# +############################################################################ +# +# Requires: UNIX or MS-DOS +# +############################################################################ + + +procedure gdl(dir) + + local getdir + getdir := set_getdir_by_os() + return getdir(dir) + +end + + + +procedure set_getdir_by_os() + + # Decide how to get a directory, based on whether we are running + # under Unix or MS-DOS. + + 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) + + # 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, temp_name, filename + 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 + # Exclude our own tempfiles (may not always be appropriate). + filename ?:= trim(trim(tab(10)) || "." || tab(13), '. ') + 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 + put(filename_list, trim(dir || filename, '*')) + } + close(in_dir) + + if *filename_list = 0 then fail + else return filename_list + +end diff --git a/ipl/procs/gdl2.icn b/ipl/procs/gdl2.icn new file mode 100644 index 0000000..fcf51ac --- /dev/null +++ b/ipl/procs/gdl2.icn @@ -0,0 +1,379 @@ +############################################################################ +# +# File: gdl2.icn +# +# Subject: Procedures to get directory lists +# +# Authors: Richard L. Goerwitz and Charles Shartsis +# +# Date: August 14, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.3+ +# +############################################################################ +# +# Gdl returns a list containing everything in a directory (whose name +# must be passed as an argument to gdl). Nothing fancy. I use this file +# as a template, modifying the procedures according to the needs of the +# program in which they are used. +# +# NOTE: MSDOS results are all in lower case +# +# Modifications: +# 1) Fixed MSDOS routines. +# 2) Added gdlrec which does same thing as gdl except it recursively descends +# through subdirectories. May choose which Unix utility to use by passing +# in method parameter. See below. +# +############################################################################ +# +# Requires: UNIX or MS-DOS +# +############################################################################ + + +procedure gdl(dir) + + local getdir + + getdir := set_getdir_by_os() + return getdir(dir) + +end + +procedure gdlrec(dir, method) + +# Unix method to use: &null for compatibility (uses "/bin/ls"), +# not null for speed (uses "find") + + local getdir + + getdir := set_getdir_rec_by_os(method) + return getdir(dir) + +end + + +procedure set_getdir_by_os() + + # Decide how to get a directory, based on whether we are running + # under Unix or MS-DOS. + + 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 set_getdir_rec_by_os(method) + + # Decide how to get a directory, based on whether we are running + # under Unix or MS-DOS. + + if find("UNIX", &features) then { + if /method then + return unix_get_dir_rec + else + return unix_get_dir_rec2 + } + else if find("MS-DOS", &features) then + return msdos_get_dir_rec + else + stop("Your operating system is not (yet) supported.") + +end + + +procedure msdos_get_dir(dir) + + # 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, temp_name, filename + 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!") + + ### Added by C. Shartsis 9/19/94 + # Make implicit current directory explicit + # Otherwise current and root directory get mapped to same thing + if (dir == "") | + (dir ? (tab(any(&letters)) & =":" & pos(0)) ) + then + dir ||:= "." + + # Make sure we have an unambiguous directory name, with backslashes + # instead of Unix-like forward slashes. + dir := trim(map(dir, "/", "\\"), '\\') + + ### Added by C. Shartsis 9/19/94 + # Put backslash back on if dir is the root directory + # Otherwise the current directory is returned + if (dir == "") | + (dir ? (tab(any(&letters)) & =":" & pos(0)) ) + then + 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 + # Exclude our own tempfiles (may not always be appropriate). + filename ?:= trim(trim(tab(10)) || "." || tab(13), '. ') + ### Change: C. Shartsis - 4/9/95 + # Exclude tempfile + if filename ? ( + ="ICONDIR." & tab(any(&digits)) & tab(any(&digits)) & tab(any(&digits)) + ) then + next + + ### Change: C. Shartsis - 9/19/94 + # Otherwise file f in directory c:\d comes out as "c:\df" instead of "c:\d\f" + #put(filename_list, map(dir || filename)) + put(filename_list, map(trim(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 msdos_get_dir_rec(dir, level) + + # 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, line, filename, raw_list + local tmp_filelist, tmp_dirlist + static temp_dir, temp_name, filename_list + initial { + temp_dir := + (trim(map(getenv("TEMPDIR"), "/", "\\"), '\\') || "\\") | + ".\\" + } + + # Establish recursion level + /level := 0 + if level = 0 then { + filename_list := list() + # Get name of tempfile to be used. + temp_name := get_dos_tempname(temp_dir) | + stop("No more available tempfile names!") + } + + # Make implicit current directory explicit + # Otherwise current and root directory get mapped to same thing + if (dir == "") | + (dir ? (tab(any(&letters)) & =":" & pos(0)) ) + then + dir ||:= "." + + # Make sure we have an unambiguous directory name, with backslashes + # instead of Unix-like forward slashes. + dir := trim(map(dir, "/", "\\"), '\\') + + # Put backslash back on if dir is the root directory + # Otherwise the current directory is returned + if (dir == "") | + (dir ? (tab(any(&letters)) & =":" & pos(0)) ) + then + 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,".") + raw_list := [] + every put(raw_list, !in_dir) + # Clean up. + close(in_dir) & remove(temp_name) + tmp_dirlist := [] + tmp_filelist := [] + every filename := ("" ~== !raw_list) do { + match(" ",filename) | match(".",filename) & next + # Process Directories + if find(" <DIR>", filename) then { + filename ?:= tab(many(~' \t')) + put(tmp_dirlist, map(trim(dir, '\\') || "\\" || filename)) + } + # Save files to list + else { + # extract the file name + filename ?:= trim(trim(tab(10)) || "." || tab(13), '. ') + # Exclude tempfile + if not (filename ? ( + ="ICONDIR." & tab(any(&digits)) & tab(any(&digits)) & tab(any(&digits)) + )) then + # Otherwise file f in directory c:\d comes out as "c:\df" instead of "c:\d\f" + put(tmp_filelist, map(trim(dir, '\\') || "\\" || filename)) + } + } + + # Add files to master list + every put(filename_list, !sort(tmp_filelist)) + # Process remaining directories + every msdos_get_dir_rec(!sort(tmp_dirlist), level + 1) + + # Check to be sure we actually managed to read some files. + if level = 0 then { + if *filename_list = 0 then fail + else return 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 + put(filename_list, trim(dir || filename, '*')) + } + close(in_dir) + + if *filename_list = 0 then fail + else return filename_list + +end + + +procedure unix_get_dir_rec(dir, level) + + # 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. + + local in_dir, filename, raw_list, cmd + local tmp_filelist, tmp_dirlist + static filename_list + + # Establish recursion level + /level := 0 + if level = 0 then + filename_list := list() + + # Append trailing slash + dir := trim(dir, '/') || "/" + + # Put tempfile entries into a list, removing blank- and + # space-initial lines. Exclude directories (i.e. return file + # names only). + cmd := "/bin/ls -FL " || dir + in_dir := open(cmd,"pr") | + stop(cmd, " will not run on this system") + raw_list := [] + every put(raw_list, !in_dir) + # Clean up. + close(in_dir) + tmp_dirlist := [] + tmp_filelist := [] + every filename := ("" ~== !raw_list) do { + if match(" ",filename) | match(".",filename) | filename[-1] == "=" then + next + if filename[-1] == "*" then + filename := filename[1:-1] + # Process Directories + if filename[-1] == "/" then + put(tmp_dirlist, dir || filename) + # Save files to list + else + put(tmp_filelist, dir || filename) + } + + # Add files to master list + every put(filename_list, !sort(tmp_filelist)) + # Process remaining directories + every unix_get_dir_rec(!sort(tmp_dirlist), level + 1) + + # Check to be sure we actually managed to read some files. + if level = 0 then { + if *filename_list = 0 then fail + else return filename_list + } + +end + + +# This works too. +# This routine is faster but depends on the Unix "find" program. +# Don't know if all Unixes have this. +procedure unix_get_dir_rec2(dir) + + local filename_list, in_dir, cmd + + dir := trim(dir, '/') || "/" + filename_list := list() + cmd := "find " || dir || " -type f -print" + in_dir := open(cmd, "pr") | + stop(cmd, " will not run on this system") + every put(filename_list, !in_dir) + close(in_dir) + + if *filename_list = 0 then fail + else return filename_list + +end diff --git a/ipl/procs/gedcom.icn b/ipl/procs/gedcom.icn new file mode 100644 index 0000000..f2524da --- /dev/null +++ b/ipl/procs/gedcom.icn @@ -0,0 +1,417 @@ +############################################################################ +# +# File: gedcom.icn +# +# Subject: Procedures for reading GEDCOM files +# +# Author: Gregg M. Townsend +# +# Date: March 25, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures read and interpret GEDCOM files, a standard +# format for genealogy databases. +# +############################################################################ +# +# gedload(f) loads GEDCOM data from file f and returns a gedcom +# record containing the following fields: +# tree root of tree of gednode records +# id table of labeled nodes, indexed by @ID@ +# fam list of FAM nodes (marriages) +# ind list of INDI nodes (individuals) +# +# The tree is composed of gednode records R containing these fields: +# level level +# id ID (label), including @...@ delimiters +# tag tag +# data data +# lnum line number +# parent parent node in tree +# ref referenced node, if any +# sub sub-entry list +# hcode unique hashcode, if INDI node +# +# gedwalk(tree) generates the nodes of the tree in preorder. +# +# Three procedures find descendants of a node based on a sequence +# of identifying tag strings: +# gedsub(R, tag...) generates subnodes specified by tag sequence +# gedval(R, tag...) generates data values of those subnodes +# gedref(R, tag...) generates nodes referenced by those subnodes +# +# Three procedures extract a person's name from an INDI record: +# gedfnf(R) produces "John Quincy Adams" form +# gedlnf(R) produces "Adams, John Quincy" form +# gednmf(R,f) produces an arbitrary format, substituting +# prefix, firstname, lastname, suffix for +# "P", "F", "L", "S" (respectively) in f +# +# geddate(R) finds the DATE subnode of a node and returns a string +# of at least 12 characters in a standard form such as "11 Jul 1767" +# or "abt 1810". It is assumed that the input is in English. +# +# gedyear(R) returns the year from the DATE subnode of a node. +# +# gedfind(g,s) generates the individuals under gedcom record g +# that are named by s, a string of whitespace-separated words. +# gedfind() generates each INDI node for which every word of s +# is matched by either a word of the individual's name or by +# the birth year. Matching is case-insensitive. +# +############################################################################ + +record gedcom( + tree, # tree of data records + id, # table of labeled nodes, indexed by @ID@ + fam, # list of FAM nodes + ind # list of INDI nodes +) + +record gednode( + level, # level + id, # ID (label), including @...@ delimiters + tag, # tag + data, # data + lnum, # line number + parent, # parent node in tree + ref, # referenced node, if any + sub, # sub-entry list + hcode # hashcode, if INDI node +) + +$define WHITESPACE ' \t\n\r' + + + +# gedload(f) -- load GEDCOM data from file f, returning gedcom record. + +procedure gedload(f) #: load GEDCOM data from file f + local line, lnum, r, curr + local root, id, fam, ind + local hset, h1, h2, c + + lnum := 0 + root := curr := gednode(-1, , "ROOT", "", lnum, , , []) + id := table() + fam := [] + ind := [] + + while line := read(f) do { + lnum +:= 1 + if *line = 0 then + next + + if not (r := gedscan(line)) then { + write(&errout, "ERR, line ", lnum, ": ", line) + next + } + r.lnum := lnum + r.sub := [] + + if r.tag == "CONC" then { # continuation line (no \n) + curr.data ||:= r.data + next + } + if r.tag == "CONT" then { # continuation line (with \n) + curr.data ||:= "\n" || r.data + next + } + + while curr.level >= r.level do + curr := curr.parent + put(curr.sub, r) + r.parent := curr + curr := r + + id[\r.id] := r + case r.tag of { + "FAM": put(fam, r) + "INDI": put(ind, r) + } + } + + every r := gedwalk(root) do + r.ref := id[r.data] + + hset := set() + every r := !ind do { + h1 := h2 := gedhi(r) + every c := !"123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" do + if member(hset, h2) then + h2 := h1 || c # add disambiguating suffix if needed + else + break + insert(hset, r.hcode := h2) + } + + return gedcom(root, id, fam, ind) +end + + + +# gedscan(f) -- scan one line of a GEDCOM record, returning gednode record + +procedure gedscan(s) # (internal procedure) + local level, id, tag, data + static alnum + initial alnum := &letters ++ &digits ++ '_' + + s ? { + tab(many(WHITESPACE)) + level := tab(many(&digits)) | fail + tab(many(WHITESPACE)) + if id := (="@" || tab(upto('@') + 1)) then + tab(many(WHITESPACE)) + tag := tab(many(alnum)) | fail + tab(many(WHITESPACE)) + data := tab(0) + return gednode(level, id, tag, data) + } +end + + + +# gedwalk(r) -- walk GEDCOM tree, generating nodes in preorder + +procedure gedwalk(r) #: generate GEDCOM tree nodes in preorder + suspend r | gedwalk(!r.sub) + fail +end + + + +# gedsub(r, field...) -- generate subrecords with given tags +# gedval(r, field...) -- generate values of subrecords with given tags +# gedref(r, field...) -- generate nodes referenced by given tags + +procedure gedsub(r, f[]) #: find subrecords + local tag, x + + tag := get(f) | fail + every x := !r.sub do { + if x.tag == tag then + if *f > 0 then + suspend gedsub ! push(f, x) + else + suspend x + } +end + +procedure gedval(a[]) #: find subrecord values + suspend (gedsub ! a).data +end + +procedure gedref(a[]) #: find referenced nodes + suspend \(gedsub ! a).ref +end + + + +# gedfnf(r) -- get name from individual record, first name first + +procedure gedfnf(r) #: get first name first + return gednmf(r, "P F L S") +end + + + +# gedlnf(r) -- get name from individual record, last name first + +procedure gedlnf(r) #: get last name first + local s + s := gednmf(r, "L, P F S") + s ? { + =", " + return tab(0) + } +end + + + +# gednmf(r, f) -- general name formatter +# +# substitutes the first name, last name, prefix, and suffix +# for the letters F, L, P, S respectively in string f. +# multiple spaces are suppressed. + +procedure gednmf(r, f) #: format name + local c, s, prefix, first, last, suffix + + prefix := gedval(r, "TITL" | "NPFX") | gedval(r, "NAME", "NPFX") + s := gedval(r, "NAME") | fail + s ? { + first := trim(tab(upto('/') | 0)) + ="/" + last := trim(tab(upto('/') | 0)) + ="/" + suffix := gedval(r, "NSFX") | ("" ~== tab(0)) + } + s := "" + f ? { + while s ||:= tab(upto('PFLS ')) do { + while c := tab(any('PFLS ')) do { + s ||:= case c of { + "P": \prefix + "F": \first + "L": \last + "S": \suffix + " ": s[-1] ~== " " + } + } + } + s ||:= tab(0) + } + return trim(s) +end + + + +# geddate(r) -- get date from record in standard form + +procedure geddate(r) #: get canonical date + local s, t, w + static ftab + initial { + ftab := table() + ftab["JAN"] := "Jan"; ftab["FEB"] := "Feb"; ftab["MAR"] := "Mar" + ftab["APR"] := "Apr"; ftab["MAY"] := "May"; ftab["JUN"] := "Jun" + ftab["JUL"] := "Jul"; ftab["AUG"] := "Aug"; ftab["SEP"] := "Sep" + ftab["OCT"] := "Oct"; ftab["NOV"] := "Nov"; ftab["DEC"] := "Dec" + ftab["ABT"] := "abt"; ftab["BEF"] := "bef"; ftab["AFT"] := "aft" + ftab["CAL"] := "cal"; ftab["EST"] := "est" + } + + s := trim(gedval(r, "DATE"), WHITESPACE) | fail + t := "" + + s ? while not pos(0) do { + tab(many(WHITESPACE)) + w := tab(upto(WHITESPACE) | 0) + t ||:= " " || (\ftab[w] | w) + } + + if *t > 13 then + return t[2:0] + else + return right(t, 12) +end + + + +# gedyear(r) -- get year from event record + +procedure gedyear(r) #: get year + local d, y + + d := gedval(r, "DATE") | fail + d ? while tab(upto(&digits)) do + if (y := tab(many(&digits)) \ 1) >= 1000 then + return y +end + + + +# gedhi -- generate hashcode for individual record +# +# The hashcode uses two initials, final digits of birth year, +# and a 3-letter hashing of the full name and birthdate fields. + +procedure gedhi(r) # (internal procedure) + local s, name, bdate, bd + static lc, uc + initial { + uc := string(&ucase) + lc := string(&lcase) + } + + s := "" + name := gedval(r, "NAME") | "" + name ? { + # prefer initial of nickname; else skip unused firstname in parens + tab(upto('"') + 1) | (="(" & tab(upto(')') + 1)) + tab(any(' \t')) + s ||:= tab(any(&letters)) | "X" # first initial + tab(upto('/') + 1) + tab(any(' \t')) + s ||:= tab(any(&letters)) | "X" # second initial + } + + bdate := geddate(gedsub(r, "BIRT")) | "" + bd := bdate[-2:0] | "00" + if not (bd ? (tab(many(&digits)) & pos(0))) then + bd := "99" + s ||:= bd || gedh3a(name || bdate) + return map(s, lc, uc) +end + + + +# gedh3a(s) -- hash arbitrary string into three alphabetic characters + +procedure gedh3a(s) # (internal procedure) + local n, d1, d2, d3, c + + n := 0 + every c := !map(s) do + if not upto(' \t\f\r\n', c) then + n := 37 * n + ord(c) - 32 + d1 := 97 + (n / 676) % 26 + d2 := 97 + (n / 26) % 26 + d3 := 97 + n % 26 + return char(d1) || char(d2) || char(d3) +end + + + +# gedfind(g, s) -- find records by name from gedcom record +# +# g is a gedcom record; s is a string of whitespace-separated words. +# gedfind() generates each INDI node for which every word of s +# is matched by either a word of the individual's name or by +# the birth year. Matching is case-insensitive. + +procedure gedfind(g, s) #: find individual by name + local r + + every r := !g.ind do + if gedmatch(r, s) then + suspend r +end + + +# gedmatch(r, s) -- match record against name +# +# s is a string of words to match name field and/or birth year. +# Matching is case sensitive. + +procedure gedmatch(r, s) # (internal procedure) + local w + + every w := gedlcw(s) do + (w == (gedlcw(gedval(r, "NAME")) | gedyear(gedsub(r, "BIRT")))) | fail + return r +end + + + +# gedlcw(s, c) -- generate words from string s separated by chars from c +# +# words are mapped to lower-case to allow case-insensitive comparisons + +procedure gedlcw(s, c) # (internal procedure) + /c := '/ \t\r\n\v\f' + map(s) ? { + tab(many(c)) + while not pos(0) do { + suspend tab(upto(c) | 0) \ 1 + tab(many(c)) + } + } + fail +end diff --git a/ipl/procs/gen.icn b/ipl/procs/gen.icn new file mode 100644 index 0000000..375c4c5 --- /dev/null +++ b/ipl/procs/gen.icn @@ -0,0 +1,445 @@ +############################################################################ +# +# File: gen.icn +# +# Subject: Procedures for meta-variant code generation +# +# Author: Ralph E. Griswold +# +# Date: April 30, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures are for use with code produced by a meta-variant +# translator. As given here, they produce an identity translation. +# Modifications can be made to effect variant translations. +# +############################################################################ + +# main() calls program(), which is produced by the meta-variant +# translation. + +procedure main() + + program() + +end + +procedure Alt_(e1, e2) # e1 | e2 + + return "(" || e1 || "|" || e2 || ")" + +end + +procedure Apply_(e1, e2) # e1 ! e2 + + return "(" || e1 || "!" || e2 || ")" + +end + +procedure Asgnop_(op, e1, e2) # e1 op e2 + + return "(" || e1 || " " || op || " " || | e2 || ")" + +end + +procedure Augscan_(e1, e2) # e1 ?:= e2 + + return "(" || e1 || " ?:= " || e2 || ")" + +end + +procedure Bamper_(e1, e2) # e1 & e2 + + return "(" || e1 || " & " || e2 || ")" + +end + +procedure Binop_(op, e1, e2) # e1 op e2 + + return "(" || e1 || " " || op || " " || e2 || ")" + +end + +procedure Break_(e) # break e + + return "break " || e + +end + +procedure Case_(e, clist) # case e of { caselist } + + return "case " || e || " of {" || clist || "}" + +end + +procedure Cclause_(e1, e2) # e1 : e2 + + return e1 || " : " || e2 || "\n" + +end + +procedure Clist_(e1, e2) # e1 ; e2 in case list + + return e1 || ";" || e2 + +end + +procedure Clit_(e) # 's' + + return "'" || e || "'" + +end + +procedure Compound_(es[]) # { e1; e2; ... } + local result + + if *es = 0 then return "{}\n" + + result := "{\n" + every result ||:= !es || "\n" + + return result || "}\n" + +end + +procedure Create_(e) # create e + + return "create " || e + +end + +procedure Default_(e) # default: e + + return "default: " || e + +end + +procedure End_() # end + + write("end") + + return + +end + +procedure Every_(e) # every e + + return "every " || e + +end + +procedure Every_Do_(e1, e2) # every e1 do e2 + + return "every " || e1 || " do " || e2 + +end + +procedure Fail_() # fail + + return "fail" + +end + +procedure Field_(e1, e2) # e . f + + return "(" || e1 || "." || e2 || ")" + +end + +procedure Global_(vs[]) # global v1, v2, ... + local result + + result := "" + every result ||:= !vs || ", " + + write("global ", result[1:-2]) + + return + +end + +procedure If_(e1, e2) # if e1 then e2 + + return "if " || e1 || " then " || e2 + +end + +procedure If_Else_(e1, e2, e3) # if e1 then e2 else e3 + + return "if " || e1 || " then " || e2 || " else " || e3 + +end + +procedure Ilit_(e) # i + + return e + +end + +procedure Initial_(s) # initial e + + write("initial ", s) + + return + +end + +procedure Invoke_(e0, es[]) # e0(e1, e2, ...) + local result + + if *es = 0 then return e0 || "()" + + result := "" + every result ||:= !es || ", " + + return e0 || "(" || result[1:-2] || ")" + +end + +procedure Key_(s) # &s + + return "&" || s + +end + +procedure Limit_(e1, e2) # e1 \ e2 + + return "(" || e1 || "\\" || e2 || ")" + +end + +procedure Link_(vs) # link "v1, v2, ..." (problem) + + write("link ", vs) + +end + +procedure List_(es[]) # [e1, e2, ... ] + local result + + if *es = 0 then return "[]" + + result := "" + every result ||:= !es || ", " + + return "[" || result[1:-2] || "]" + +end + +procedure Local_(vs[]) # local v1, v2, ... + local result + + result := "" + every result ||:= !vs || ", " + + write("local ", result[1:-2]) + + return + +end + +procedure Next_() # next + + return "next" + +end + +procedure Null_() # &null + + return "" + +end + +procedure Paren_(es[]) # (e1, e2, ... ) + local result + + if *es = 0 then return "()" + + result := "" + every result ||:= !es || ", " + + return "(" || result[1:-2] || ")" + +end + +procedure Pdco_(e0, es[]) # e0{e1, e2, ... } + local result + + if *es = 0 then return e0 || "{}" + + result := "" + every result ||:= !es || ", " + + return e0 || "{" || result[1:-2] || "}" + +end + +procedure Proc_(s, es[]) # procedure s(v1, v2, ...) + local result, e + + if *es = 0 then write("procedure ", s, "()") + + result := "" + every e := !es do + if e == "[]" then result[-2:0] := e || ", " + else result ||:= (\e | "") || ", " + + write("procedure ", s, "(", result[1:-2], ")") + + return + +end + +procedure Record_(s, es[]) # record s(v1, v2, ...) + local result, field + + if *es = 0 then write("record ", s, "()") + + result := "" + every field := !es do + result ||:= (\field | "") || ", " + + write("record ", s, "(", result[1:-2], ")") + + return + +end + +procedure Reduce_(s[]) # used in code generation + + every write(!s) + + return + +end + +procedure Repeat_(e) # repeat e + + return "repeat " || e + +end + +procedure Return_(e) # return e + + return "return " || e + +end + +procedure Rlit_(e) + + return e + +end + +procedure Scan_(e1, e2) # e1 ? e2 + + return "(" || e1 || " ? " || e2 || ")" + +end + +procedure Section_(op, e1, e2, e3) # e1[e2 op e3] + + return e1 || "[" || e2 || op || e3 || "]" + +end + +procedure Slit_(s) # "s" + + return image(s) + +end + +procedure Static_(ev[]) # static v1, v2, .. + local result + + result := "" + every result ||:= !ev || ", " + + write("static ", result[1:-2]) + + return + +end + +procedure Subscript_(e1, e2) # e1[e2] + + return e1 || "[" || e2 || "]" + +end + +procedure Suspend_(e) # suspend e + + return "suspend " || e + +end + +procedure Suspend_Do_(e1, e2) # suspend e1 do e2 + + return "suspend " || e1 || " do " || e2 + +end + +procedure To_(e1, e2) # e1 to e2 + + return "(" || e1 || " to " || e2 || ")" + +end + +procedure To_By_(e1, e2, e3) # e1 to e2 by e3 + + return "(" || e1 || " to " || e2 || " by " || e3 || ")" + +end + +procedure Repalt_(e) # |e + + return "(|" || e || ")" + +end + +procedure Unop_(op, e) # op e + + return "(" || op || e || ")" + +end + +procedure Not_(e) # not e + + return "not(" || e || ")" + +end + +procedure Until_(e) # until e + + return "until " || e + +end + +procedure Until_Do_(e1, e2) # until e1 do e2 + + return "until " || e1 || " do " || e2 + +end + +procedure Var_(s) # v + + return s + +end + +procedure While_(e) # while e + + return "while " || e + +end + +procedure While_Do_(e1, e2) # while e1 do e2 + + return "while " || e1 || " do " || e2 + +end diff --git a/ipl/procs/gener.icn b/ipl/procs/gener.icn new file mode 100644 index 0000000..5a06020 --- /dev/null +++ b/ipl/procs/gener.icn @@ -0,0 +1,80 @@ +############################################################################ +# +# File: gener.icn +# +# Subject: Procedures to generate miscellaneous sequences +# +# Author: Ralph E. Griswold +# +# Date: March 25, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures generate sequences of results. +# +# days() days of the week. +# +# hex() sequence of hexadecimal codes for numbers +# from 0 to 255 +# +# label(s,i) sequence of labels with prefix s starting at i +# +# multii(i, j) sequence of i * j i's +# +# months() months of the year +# +# octal() sequence of octal codes for numbers from 0 to 255 +# +# star(s) sequence consisting of the closure of s +# starting with the empty string and continuing +# in lexical order as given in s +# +############################################################################ + +procedure days() + + suspend "Sunday" | "Monday" | "Tuesday" | "Wednesday" | "Thursday" | + "Friday" | "Saturday" + +end + +procedure hex() + + suspend !"0123456789abcdef" || !"0123456789abcdef" + +end + +procedure label(s,i) + + suspend s || (i | (i +:= |1)) + +end + +procedure multii(i, j) + + suspend (i to i * j) & i + +end + +procedure months() + + suspend "January" | "February" | "March" | "April" | "May" | "June" | + "July" | "August" | "September" | "October" | "November" | "December" + +end + +procedure octal() + + suspend (0 to 3) || (0 to 7) || (0 to 7) + +end + +procedure star(s) + + suspend "" | (star(s) || !s) + +end diff --git a/ipl/procs/genrfncs.icn b/ipl/procs/genrfncs.icn new file mode 100644 index 0000000..b9d0b0a --- /dev/null +++ b/ipl/procs/genrfncs.icn @@ -0,0 +1,810 @@ +############################################################################ +# +# File: genrfncs.icn +# +# Subject: Procedures to generate sequences +# +# Author: Ralph E. Griswold +# +# Date: March 4, 2003 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures generate sequences of results. +# +# arandseq(i, j) arithmetic sequence starting at i with randomly +# chosen increment between 1 and j +# +# arithseq(i, j) arithmetic sequence starting at i with increment j +# +# beatty1seq() Beatty's first sequence i * &phi +# +# beatty2seq() Beatty's second sequence i * &phi ^ 2 +# +# catlnseq(i) sequence of generalized Catalan numbers +# +# cfseq(i, j) continued-fraction sequence for i / j +# +# chaosseq() chaotic sequence +# +# chexmorphseq() sequence of centered hexamorphic numbers +# +# connellseq(p) generalized Connell sequence +# +# dietzseq(s) Dietz sequence for polynomial +# +# dressseq(i) dress sequence with increment i, default 1 (Schroeder) +# +# eisseq(i) EIS A sequence for i +# +# factseq() factorial sequence +# +# fareyseq(i, k) Farey fraction sequence; k = 0, the default, produces +# numerator sequence; k = 1 produces denominator +# sequence +# +# fibseq(i, j, k, m) generalized Fibonacci sequence (Lucas sequence) +# with initial values i and j and additive constant +# k. If m is supplied, the results are produced +# mod m. +# +# figurseq(i) series of ith figurate number +# +# fileseq(s, i) generate from file s; if i is null, lines are generated. +# Otherwise characters, except line terminators. +# +# friendseq(k) generate random friendly sequence from k values, 1 to k +# (in a friendly sequence, successive terms differ by 1). +# +# +# geomseq(i, j) geometric sequence starting at i with multiplier j +# +# hailseq(i) hailstone sequence starting at i +# +# irepl(i, j) j instances of i +# +# lindseq(f, i) generate symbols from L-system in file f; i if +# present overrides the number of generations specified +# in the L-system. +# +# logmapseq(k, x) logistic map +# +# lrrcseq(L1, L2) +# generalized linear recurrence with constant +# coefficients; L1 is a list of initial terms, +# L2 is a list of coefficients for n previous values, +# where n = *L2 +# +# meanderseq(s, n) sequences of all characters that contain all n-tuples +# of characters from s +# +# mthueseq() Morse-Thue sequence +# +# mthuegseq(i) Morse-Thue sequence for base i +# +# multiseq(i, j, k) sequence of (i * j + k) i's +# +# ngonalseq(i) sequence of the ith polygonal number +# +# nibonacciseq(values[]) +# generalized Fibonacci sequence that sums the +# previous n terms, where n = *values. +# +# partitseq(i, j, k) sequence of integer partitions of i with minimum j +# and maximum k +# +# pellseq(i, j, k) generalized Pell's sequence starting with i, j and +# using multiplier k +# +# perrinseq() Perrin sequence +# +# polyseq(coeff[]) polynomial in x evaluated for x := seq() +# +# primeseq() the sequence of prime numbers +# +# powerseq(i) sequence n ^ i, n = 1, 2, 3, 4, ... +# +# powersofseq(i) sequence i ^ n, n = 1, 2, 3, 4, ...n +# +# rabbitseq() rabbit sequence +# +# ratsseq(i) versumseq() with sort +# +# signaseq(r) signature sequence of r +# +# spectseq(r) spectral sequence integer(i * r), i - 1, 2, 3, ... +# +# srpseq(n, m) palindromic part of the continued-fraction sequence +# for sqrt(n^2+m) +# +# versumseq(i, j) generalized sequence of added reversed integers with +# seed i (default 196) and increment j (default 0) +# +# versumopseq(i, p) procedure p (default 1) applied to versumseq(i) +# +# vishwanathseq() random variation on Fibonacci sequence +# +# zebra(values[]) zebra colors, alternating 2 and 1, for number of +# times given by successive values +# +############################################################################ +# +# Requires: co-expressions +# +############################################################################ +# +# Links: convert, fastfncs, io, partit, numbers, rational, xcode +# polynom, strings +# +############################################################################ + +link convert +link lists +link fastfncs +link io +link numbers +link partit +link polynom +link rational +link xcode +link periodic +link factors +link strings + +procedure arandseq(i, j) #: arithmetic sequence with random intervals + + /i := 1 + /j := 1 + + suspend seq(i) + ?j + +end + +procedure arithseq(i, j) #: arithmetic sequence + + /i := 1 + /j := 0 + + suspend seq(i) + j + +end + +procedure beatty1seq(r) #: Beatty sequence 1 + + /r := &phi + + suspend integer(seq() * r) + +end + +procedure beatty2seq(r) #: Beatty sequence 2 + + /r := &phi + + suspend integer(seq() * (r / (r - 1))) + +end + +procedure catlnseq(i) #: generalized Catalan sequence + local k + + /i := 1 + + suspend (i := 1, k := seq(), i *:= 4 * k + 2, i /:= k + 2) + +end + +procedure chaosseq() #: Hofstadter's chaotic sequence + + suspend q(seq()) + +end + +# The generalization here is to allow a generating procedure, p to +# be specified. The default is seq(). Arguments are given in args. + +procedure connellseq(p, args[]) #: generalized Connell sequence + local i, j, count, parity, parity2, C + + C := create (\p | seq) ! args + + count := 0 + parity := 0 + parity2 := 1 + + repeat { + count +:= 1 + parity :=: parity2 + j := 0 + repeat { + i := @C | fail + if i % 2 = parity then { + suspend i + j +:= 1 + if j = count then break + } + } + } + +end + +procedure chexmorphseq() #: sequence of centered hexamorphic numbers + local i, j + + every (i := seq(), j := 3 * i * (i - 1) + 1, j ? { + tab(-*i) + if =i then suspend j + }) + +end + +procedure cfseq(i, j) #: continued-fraction sequence + local r + + until j = 0 do { + suspend integer(i / j) + r := i % j + i := j + j := r + } + +end + +procedure dietzseq(str) + + suspend !poly2profile(peval(str)) + +end + +procedure dressseq(i) + local seq, seq1, n + + /i := 1 + + seq := [0] + + suspend seq[1] + + repeat { + seq1 := copy(seq) + every n := !seq + i do { + suspend n + put(seq1, n) + } + seq := seq1 + } + +end + +procedure eisseq(i) #: EIS A sequence + local input, seq + static lst + + initial { + input := dopen("eis.seq") | fail + lst := xdecode(input) | fail + close(input) + } + + seq := \lst[integer(i)] | fail + + suspend !seq + +end + +procedure factseq() #: factorial sequence + local i + + i := 1 + + suspend i *:= seq() + +end + +record farey(magnitude, n, d) + +procedure fareyseq(i, k) #: Farey fraction sequence + local farey_list, n, d, x + + /k := 0 # default numerators + + k := integer(k) | fail + + farey_list := [farey(0.0, 0, 1)] + + every d := 1 to i do + every n := 1 to d do { + if gcd(n, d) = 1 then + put(farey_list, farey(real(n) / d, n, d)) + } + + farey_list := sortf(farey_list, 1) + + case k of { + 0 : every suspend (!farey_list).n # numerator sequence + 1 : every suspend (!farey_list).d # denominator sequence + } + +end + +procedure fareydseq(i) #: Farey fraction denominator sequence + local parity, j + + parity := 1 + + every j := fareyseq(i) do { + if parity < 0 then suspend j + parity *:= -1 + } + +end + +procedure fareynseq(i) #: Farey fraction numerator sequence + local parity, j + + parity := 1 + + every j := fareyseq(i) do { + if parity > 0 then suspend j + parity *:= -1 + } + +end + +procedure fareyn1seq(i) #: Farey fraction numerator sequence, 1-based + + suspend fareynseq(i) + 1 + +end + +procedure fibseq(i, j, k, m) #: generalized Fibonacci sequence + local n + + /i := 1 + /j := 1 + /k := 0 + + if /m then { + suspend i | j | |{ + n := i + j + k + i := j + j := n + } + } + else { + suspend i % m | j % m | |{ + n := (i + j + k) % m + i := j + j := n + } + } + +end + +# Warning; if not all lines are generated from the input file, the +# file is not closed until the next call of fileseq(). + +procedure fileseq(s, i) #: sequence from file + static input + + close(\input) + + input := dopen(s) | fail + + if /i then suspend !input + else suspend !!input + + close(input) + + input := &null + +end + +procedure figurseq(i) #: sequence of figurate numbers + local j, k + + /i := 1 + + suspend (j := 1, k := seq(i), j *:= k + 1, j /:= k + 1 - i) + +end + +procedure friendseq(k) #: random friendly sequence + local state + + state := ?k + + repeat { + suspend state + case state of { + 1 : state +:= 1 + k : state -:= 1 + default : state +:= ?[1, -1] + } + } + +end + +procedure geomseq(i, j) #: geometric sequence + + /i := 1 + /j := 1 + + suspend seq(i) * j + +end + +procedure hailseq(i) #: hailstone sequence + + /i := 1 + + suspend |if i % 2 = 0 then i /:= 2 else i := 3 * i + 1 + +end + +procedure irepl(i, j) #: repeated sequence + + /i := 1 + /j := 1 + + suspend |i \ j + +end + +procedure lindseq(f, i, p) # generate symbols from L-system + local input, gener + + /p := "lindsys" + + if \i then input := open(p || " -g " || i || " <" || f, "p") + else input := open(p || " <" || f, "p") + + while gener := read(\input) do + suspend !gener + + close(input) # pipe will be left open if not all result are generated + + fail + +end + +procedure logmapseq(k, x) # logistic map + + suspend x := k * x * (1 - |x) + +end + +procedure linrecseq(terms, coeffs) #: synonym for lrrcseq + linrecseq := lrrcseq + + suspend lrrcseq(terms, coeffs) + +end + +procedure lrrcseq(terms, coeffs) #: linear recurrence sequence + local i, term + + suspend !terms + + repeat { + term := 0 + every i := 1 to *coeffs do + term +:= terms[i] * coeffs[-i] + suspend term + get(terms) + put(terms, term) + } + +end + +procedure meanderseq(alpha, n) #: generate meandering characters + local sequence, trial, i, c + + i := *alpha + + sequence := repl(alpha[1], n - 1) # base string + + while c := alpha[i] do { # try a character + trial := right(sequence, n - 1) || c + if find(trial, sequence) then + i -:= 1 + else { + sequence ||:= c # add it + i := *alpha # and start from end again + suspend c + } + } + +end + +procedure mthueseq() #: Morse-Thue sequence + local s, t + + s := 0 + + suspend s + + repeat { + t := map(s, "01", "10") + every suspend integer(!t) + s ||:= t + } + +end + +procedure mthuegseq(j) #: generalized Morse-Thue sequence + + suspend adr(exbase10(seq(0), j)) % j # only works through base 10 + +end + +procedure multiseq(i, j, k) #: sequence of repeated integers + + /i := 1 + /j := 1 + /k := 0 + + suspend (i := seq(i), (|i \ (i * j + k)) & i) + +end + +procedure ngonalseq(i) #: sequence of polygonal numbers + local j, k + + /i := 2 + + k := i - 2 + + suspend ((j := 1) | (j +:= 1 + k * seq())) + +end + +procedure nibonacciseq(values[]) #: n-valued Fibonacci generalization + local sum + + if *values = 0 then fail + + suspend !values + + repeat { + sum := 0 + every sum +:= !values + suspend sum + get(values) + put(values, sum) + } + +end + +procedure partitseq(i, j, k) #: sequence of integer partitions + + /i := 1 + /j := 1 + /k := i + + suspend !partit(i, j, k) + +end + +procedure pellseq(i, j, k) #: generalized Pell sequence + local m + + /i := 1 + /j := 2 + /k := 2 + + suspend i | j | |{ + m := i + k * j + i := j + j := m + } + +end + +procedure perrinseq() #: perrin sequence + local i, j, k, l + + suspend i := 0 + suspend j := 2 + suspend k := 3 + + repeat { + suspend l := i + j + i := j + j := k + k := l + } + +end + +procedure polyseq(coeff[]) #: sequence of polynomial evaluations + local i, j, sum + + every i := seq() do { + sum := 0 + every j := 1 to *coeff do + sum +:= coeff[j] * i ^ (j - 1) + suspend sum + } + +end + +procedure primeseq() #: sequence of prime numbers + local i, k + + suspend 2 | ((i := seq(3, 2)) & (not(i = (k := (3 to sqrt(i) by 2)) * + (i / k))) & i) + +end + +procedure powersofseq(i) #: powers + + /i := 2 + + suspend i ^ seq(i) + +end + +procedure powerseq(i) #: powers sequence + + suspend seq() ^ i + +end + +procedure rabbitseq() #: rabbit sequence + local seq, i + + seq := [0] + + suspend 1 + + repeat { + i := get(seq) + suspend i + if i = 0 then put(seq, 1) + else put(seq, 1, 0) + } + +end + +procedure ratsseq(i, p) #: reverse add and then sort sequence + + /p := 1 + + repeat { + i +:= reverse(i) + i := integer(p(csort(i))) + suspend i + } + +end + +record entry(value, i, j) + +procedure signaseq(r, n, m) #: signature sequence + local i, j, result + + /n := 100 + /m := 100 + + result := [] + + every j := 1 to n do + every i := 1 to m do + put(result, entry(i + j * r, i, j)) + + result := sortf(result, 1) + + suspend (!result)[2] + +end + +procedure spectseq(r) #: spectral sequence + + /r := 1.0 + + suspend integer(seq() * r) + +end + + +procedure srpseq(n, m) #: generate square-root palindrome + local iter, count, okay, rat, j, pal + + if not (1 <= m <= 2 * n) then fail + + iter := 5 + + repeat { + pal := [] + count := 0 + okay := 1 + rat := Sqrt(n ^ 2 + m, iter) + every j := cfseq(rat.numer, rat.denom) do { + count +:= 1 + if count = 1 then next # don't examine first term + if j = 2 * n then { # presumed end + if not lequiv(pal, lreverse(pal)) then break + okay := &null + break + } + else if j > n then break # too big; error + else put(pal, j) + } + if \okay then { + iter +:= 1 # back to repeat loop + if iter > 12 then fail # too many iterations required. + next + } + break + } + + suspend !pal + +end + +procedure versumseq(i, j) #: generalized reversed-sum sequence + + /j := 0 + + /i := 196 + + repeat { + i +:= reverse(i) + j + suspend i + } + +end + +procedure versumopseq(i, p, args[]) #: versum sequence with operator + + /i := 196 + + /p := csort + + push(args, &null) # make room for first argument + + repeat { + i := reverse(i) + args[1] := i # make current i first argument + i := integer(p ! args) + suspend i + } + +end + +procedure vishwanathseq(i, j) #: random variation on Fibonacci sequence + local m + + /i := 1 + /j := 1 + + suspend i | j | |{ + m := case ?4 of { + 1 : i + j + 2 : i - j + 3 : -i + j + 4 : -i - j + } + i := j + j := m + } + +end + +procedure zebra(args[]) #: black and white bands + local i, clr, clr_alt + + clr := 2 # light + clr_alt := 1 # dark + + while i := get(args) do { + suspend (1 to i) & clr + clr :=: clr_alt + } + +end diff --git a/ipl/procs/geodat.icn b/ipl/procs/geodat.icn new file mode 100644 index 0000000..378fe1d --- /dev/null +++ b/ipl/procs/geodat.icn @@ -0,0 +1,1277 @@ +############################################################################ +# +# File: geodat.icn +# +# Subject: Procedures for geodetic datum conversion +# +# Authors: William S. Evans and Gregg M. Townsend +# +# Date: July 31, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures provide "projections" that convert among geodetic +# datums, which relate locations on the earth's surface to longitude +# and latitude coordinates. As measurement techniques improve, +# newer datums typically give slightly different values from older +# ones. The values returned here are used with the project() +# procedure of cartog.icn. +# +# geodat(s1, s2) defines a geodetic datum conversion. +# molodensky() performs an algorithmic datum conversion. +# nadcon(s1, s2) uses data files for more precise conversion. +# +# ellipsoid(s) return the parameters of the named ellipsoid. +# +############################################################################ +# +# geodat(f, t) returns a projection from longitude and latitude +# in datum f to longitude and latitude in datum t. +# f and t are strings. If f and t equal "NAD83", "NAD27", +# "HARN", or "HPGN", geodat returns a nadcon projection. +# Failing that, geodat returns a molodensky projection. +# +# The input to the projection is a list of signed numeric values, +# angles measured in degrees, with each pair representing one +# location; longitude precedes latitude. The output is a list +# with the same form and length as the input list. +# +############################################################################ +# +# nadcon(f, t) returns a projection from longitude and latitude +# in datum f to longitude and latitude in datum t. The strings +# f and t must each be one of "NAD83", "NAD27", "HARN", or "HPGN". +# The projection uses our implementation of the National Oceanic +# and Atmospheric Administration's (NOAA's) North American Datum +# Conversion Utility (NADCON); for more information, see +# http://www.ngs.noaa.gov/TOOLS/Nadcon/Nadcon.html +# +# nadcon() requires data grid (.loa and .laa) files, which must be +# found in the current directory or along the space-separated path +# given by the environment variable DPATH. These files can be +# downloaded from: +# http://www.cs.arizona.edu/icon/ftp/data/nadcon/ +# ftp://ftp.cs.arizona.edu/icon/data/nadcon/ +# +# The projection's input and output are lists of signed numbers. +# Output is properly rounded and so may not agree exactly with +# the equivalent NOAA programs. +# +############################################################################ +# +# molodensky(dx, dy, dz, ain, fin, aout, fout) returns a projection +# from input longitude and latitude to output longitude and latitude. +# The projection uses the standard Molodensky transformation. +# The input datum is specified by an ellipsoid with parameters +# ain, the equatorial radius in metres, and fin, the flattening; +# and by three shift values dx, dy, and dz. The output datum is +# specified by an ellipsoid with parameters aout and fout. +# +# If dz is null, then dx and dy are interpreted as the names of +# an input and output datum. The names are the ID codes +# specified in NIMA TR 8350.2. +# +# The projection's input and output are lists of signed numbers. +# +############################################################################ +# +# ellipsoid(s) return a list [a, 1/f] containing the defining +# parameters of the standard ellipsoid model named s; a is the +# equatorial radius and 1/f is the flattening factor. Names are +# listed in the code; the default is "WGS84". +# +############################################################################ +# +# Ellipsoid and datum parameters are from: +# +# Department of Defense World Geodetic System 1984 +# National Imagery and Mapping Agency +# Technical Report TR8350.2 +# Third Edition, Amendment 1 (3 January 2000) +# ftp://ftp.nima.mil/pub/gg/tr8350.2/ +# +############################################################################ +# +# Links: cartog, io +# +############################################################################ + + + +link cartog +link io + + + +# Procedures and globals named with a "gdt_" prefix are +# not intended for access outside this file. + +global gdt_datum_ptab # table of gdt_datum_rec's, keyed by code + + + +###################### Geodat Conversion ################################# + +procedure geodat(f, t) #: define geodetic conversion + return nadcon(f, t) | molodensky(f, t) | fail +end + + + +###################### NADCON Conversion ################################# + +record gdt_nadcon( # nadcon conversion record + proj, # projection procedure + inv, # invert myself + grids # list of gdt_nadcon_grid records to search + ) + +record gdt_nadcon_grid( # information about a .loa and .laa file + name, # name of file + offset, # offset in file to start of grid data + termLen, # number of chars in line termination (1 or 2) + nc, nr, nz, # number of rows, columns in file (nz = ??) + xmin, xmax, dx, # dimension of coverage + ymin, ymax, dy, # + angle # ?? + ) + +procedure nadcon(f, t) #: define NAD data conversion + local d, ft + + ft := (gdt_nadcon_datum(f) || "-" || gdt_nadcon_datum(t)) | fail + d := gdt_nadcon() + d.inv := gdt_nadcon_inv + case ft of { + "NAD27-NAD83"|"NAD83-NAD27": + # more specific grids should precede less specific ones + d.grids := gdt_nadcon_initGrids( + ["hawaii","prvi","stlrnc", "stgeorge","stpaul","alaska","conus"]) + "NAD83-HPGN"|"HPGN-NAD83": + d.grids := gdt_nadcon_initGrids( + ["alhpgn","azhpgn","cnhpgn","cohpgn","cshpgn","emhpgn","ethpgn", + "flhpgn","gahpgn","hihpgn","inhpgn","kshpgn","kyhpgn","lahpgn", + "mdhpgn","mehpgn","mihpgn","mshpgn","nbhpgn","ndhpgn","nehpgn", + "nmhpgn","nvhpgn","nyhpgn","ohhpgn","okhpgn","pvhpgn","sdhpgn", + "tnhpgn","uthpgn","vahpgn","wihpgn","wmhpgn","wohpgn","wthpgn", + "wvhpgn","wyhpgn"]) + "NAD27-HPGN": + return compose(nadcon("NAD27", "NAD83"), nadcon("NAD83", "HPGN")) + "HPGN-NAD27": + return compose(nadcon("HPGN", "NAD83"), nadcon("NAD83", "NAD27")) + default: # identity conversion + d.grids := [] + } + case ft of { + "NAD27-NAD83"|"NAD83-HPGN": d.proj := gdt_nadcon_fwd + "NAD83-NAD27"|"HPGN-NAD83": d.proj := gdt_nadcon_bck + default: d.proj := gdt_identity + } + return d +end + +procedure gdt_nadcon_fwd(p, L) + local i, a + + a := [] + every i := 1 to *L by 2 do { + gdt_nadcon_fwdPoint(p, a, L[i], L[i+1]) | fail + } + return a +end + +procedure gdt_nadcon_bck(p, L) + local i, a + + a := [] + every i := 1 to *L by 2 do { + gdt_nadcon_bckPoint(p, a, L[i], L[i+1]) | fail + } + return a +end + +procedure gdt_identity(p, L) + return L +end + +procedure gdt_nadcon_inv(p) + local q + + q := copy(p) + case p.proj of { + gdt_nadcon_bck : q.proj := gdt_nadcon_fwd + gdt_nadcon_fwd : q.proj := gdt_nadcon_bck + gdt_identity : q.proj := gdt_identity + } + return q +end + +procedure gdt_nadcon_datum(x) + case x of { + "NAD27": return "NAD27" + "NAD83": return "NAD83" + "HARN" | "HPGN": return "HPGN" + } +end + + +procedure gdt_nadcon_initGrids(names) + local grids, latf, lonf, a1, a2, b1, b2, g + + grids := [] + every name := !names do { + close(\lonf) + close(\latf) + + g := gdt_nadcon_grid() + g.name := name + + lonf := dopen(name || ".loa") | &null + latf := dopen(name || ".laa") | &null + + if /lonf | /latf then next # filename unreadable + + a1 := read(lonf) | &null + a2 := read(lonf) | &null + b1 := read(latf) | &null + b2 := read(latf) | &null + if /a1 | /a2 | /b1 | /b2 | a1 ~== b1 | a2 ~== b2 then { + write(&errout, g.name, " incompatible or corrupt files.") + next + } + g.offset := where(lonf) + + if g.offset = 141 then + g.termLen := 2 + else + g.termLen := 1 + a2 ? { + g.nc := integer(move(4)) + g.nr := integer(move(4)) + g.nz := integer(move(4)) + g.xmin := real(move(12)) + g.dx := real(move(12)) + g.xmax := g.xmin + (g.nc - 1) * g.dx + g.ymin := real(move(12)) + g.dy := real(move(12)) + g.ymax := g.ymin + (g.nr - 1) * g.dy + g.angle := real(move(12)) + put(grids, g) + } + } + close(\lonf) + close(\latf) + + if *grids = 0 then { + write(&errout, "No valid NADCON conversion files found.") + fail + } + return grids +end + +procedure gdt_nadcon_findGrid(grids, xpt, ypt) + local g + + every g := !grids do { + if (g.xmin < xpt < g.xmax & g.ymin < ypt < g.ymax) then return g + } + fail +end + +procedure gdt_nadcon_box(f, g, xcol, yrow) +# This procedure is very sensitive to the format of the .loa & .laa +# files. In particular, it assumes: +# 1) each line contains 6 numbers (except, possibly, the +# last line of a row, which contains (nc % 6) numbers, +# 2) each number is 12 chars long, + local charsPerRow, pos, t1, t2, t3, t4 + + charsPerRow := (72 + g.termLen) * integer(g.nc / 6) + if (g.nc % 6) > 0 then + charsPerRow +:= g.termLen + 12 * (g.nc % 6) + + pos := g.offset + charsPerRow * (yrow - 1) + + (72 + g.termLen) * integer((xcol - 1) / 6) + 12 * ((xcol - 1) % 6) + + seek(f, pos) + t1 := reads(f, 12) + if (xcol % 6 = 0) then reads(f, g.termLen) # line termination + t3 := reads(f, 12) + seek(f, pos + 12 * g.nc + g.termLen * ceil(g.nc / 6.0)) + t2 := reads(f, 12) + if (xcol % 6 = 0) then reads(f, g.termLen) # line termination + t4 := reads(f, 12) + + return [real(t1), real(t2), real(t3), real(t4)] +end + + +procedure gdt_nadcon_fwdPoint(p, a, xpt, ypt) + local g, latf, lonf, xgrid, ygrid, xcol, yrow, t, dlas, dlos + + if not(g := gdt_nadcon_findGrid(p.grids, xpt, ypt)) then { + runerr(205, [xpt, ypt]) # point not in available areas + fail + } + lonf := dopen(g.name || ".loa") + latf := dopen(g.name || ".laa") + + xgrid := (xpt - g.xmin) / g.dx + 1.0 + ygrid := (ypt - g.ymin) / g.dy + 1.0 + xcol := integer(xgrid) + yrow := integer(ygrid) + + t := gdt_nadcon_box(lonf, g, xcol, yrow) + dlos := t[1] + (t[3]-t[1]) * (xgrid-xcol) + (t[2]-t[1]) * (ygrid-yrow) + + (t[4]-t[3]-t[2]+t[1]) * (xgrid-xcol) * (ygrid-yrow) + + t := gdt_nadcon_box(latf, g, xcol, yrow) + dlas := t[1] + (t[3]-t[1]) * (xgrid-xcol) + (t[2]-t[1]) * (ygrid-yrow) + + (t[4]-t[3]-t[2]+t[1]) * (xgrid-xcol) * (ygrid-yrow) + + close(lonf) + close(latf) + + # Why is the range specified in +east and the correction in +west? + put(a, xpt - dlos / 3600.0, ypt + dlas / 3600.0) + return +end + +$define CTG_NADCON_SMALL 0.000000001 # close enough for NADCON inverse + +procedure gdt_nadcon_bckPoint(p, a, xpt, ypt) + local xguess, yguess, b, i, dx, dy + + xguess := xpt + yguess := ypt + b := [] + every i:= 1 to 10 do { + gdt_nadcon_fwdPoint(p, b, xguess, yguess) | fail + dx := xpt - get(b) + dy := ypt - get(b) + if abs(dx) > CTG_NADCON_SMALL then xguess +:= dx + if abs(dy) > CTG_NADCON_SMALL then yguess +:= dy + if abs(dx) <= CTG_NADCON_SMALL & abs(dy) <= CTG_NADCON_SMALL then { + put(a, xguess, yguess) + return + } + } + write(&errout, "Maximum iterations exceeded!!") + fail +end + + + +################# Standard Molodensky Datum Transformation ################## +# See NIMA TR 8350.2 +# +# ************************ WARNING ****************************************** +# NIMA TR 8350.2 contains Molodensky parameters to convert +# from an arbitrary datum to WGS84. To convert from datum A to datum B, +# I call molodensky(Ax-Bx,Ay-By,Az-Bz,Aa,Af,Ba,Bf) where Ax,Ay,Az are the +# shift to convert A to WGS84; Bx,By,Bz are the shift to convert B to WGS84; +# Aa,Af,Ba,Bf are the ellipsoid parameters. +# ************************ WARNING ****************************************** +# +# TODO: +# 1) Add special conversion for North and South pole +# 2) Add Multiple Regression Equations +# 3) Add special WGS72 to WGS84 conversion +# +record gdt_molo( + proj, # projection procedure (always gdt_molo_proj) + inv, # invert myself (always gdt_molo_inv) + dx, dy, dz, # x,y,z differences (output - input) + ain, fin, # input ellipsoid specs + aout, fout # output ellipsoid specs + ) + +procedure molodensky(dx,dy,dz,ain,fin,aout,fout) #: define geodetic conversion + local p, a, din, ein, dout, eout + + if /dx | /dy then fail + if /dz then { + din := gdt_datum_params(dx) | fail + ein := ellipsoid(din.eps) | fail + dout := gdt_datum_params(dy) | fail + eout := ellipsoid(dout.eps) | fail + a := [] + put(a, din.dx - dout.dx, din.dy - dout.dy, din.dz - dout.dz) + put(a, ein[1], ein[2], eout[1], eout[2]) + return molodensky ! a + } + p := gdt_molo() + p.proj := gdt_molo_proj + p.inv := gdt_molo_inv + p.dx := dx + p.dy := dy + p.dz := dz + p.ain := ain + p.fin := fin + p.aout := aout + p.fout := fout + return p +end + +procedure gdt_molo_proj(p, L) + local e2, slam, clam, sphi, cphi, Rm, Rn, dlam, dphi + local i, bbya, da, df, lam, phi, lllist + + da := p.aout - p.ain + df := p.fout - p.fin + e2 := p.fin * (2 - p.fin) + bbya := 1. - p.fin + lllist := [] + every i := 1 to *L by 2 do { + lam := dtor(L[i]) + slam := sin(lam) + clam := cos(lam) + phi := dtor(L[i+1]) + sphi := sin(phi) + cphi := cos(phi) + Rm := p.ain * (1 - e2) / (1 - e2 * sphi ^ 2) ^ (1.5) + Rn := p.ain / sqrt(1 - e2 * sphi ^ 2) + dlam := (-p.dx * slam + p.dy * clam) / (Rn * cphi) + dphi := (-p.dx * sphi * clam - p.dy * sphi * slam + p.dz * cphi + + da * (Rn * e2 * sphi * cphi) / p.ain + + df * (Rm / bbya + Rn * bbya) * sphi * cphi) / Rm + put(lllist, rtod(lam + dlam), rtod(phi + dphi)) + } + return lllist +end + +procedure gdt_molo_inv(p) + local q + + q := gdt_molo() + q.proj := gdt_molo_proj + q.inv := gdt_molo_inv + q.dx := -p.dx + q.dy := -p.dy + q.dz := -p.dz + q.ain := p.aout + q.fin := p.fout + q.aout := p.ain + q.fout := p.fin + return q +end + + + +###################### Ellipsoid Parameters ################################# + +procedure ellipsoid(name) #: return [a, 1/f] for named ellipsoid + local f, line, w, i + + /name := "WGS84" + return case name of { + "Airy 1830"|"Airy"|"AA": [6377563.396, 1 / 299.3249646] + "Australian National"|"AN": [6378160.0, 1 / 298.25] + "Bessel 1841"|"BR": [6377397.155, 1 / 299.1528128] + "Bessel 1841 (Namibia)"|"BN": [6377483.865, 1 / 299.1528128] + "Clarke 1866"|"Clarke66"|"NAD27"|"CC": [6378206.4, 1 / 294.9786982] + "Clarke 1880"|"CD": [6378249.145, 1 / 293.465] + "Everest 1830"|"Everest"|"EA": [6377276.345, 1 / 300.8017] + "Everest 1948"|"Modified Everest"|"EE": [6377304.063, 1 / 300.8017] + "Everest 1956"|"EC": [6377301.243, 1 / 300.8017] + "Everest 1969"|"ED": [6377295.664, 1 / 300.8017] + "Everest (Pakistan)"|"EF": [6377309.613, 1 / 300.8017] + "Everest (Sabah & Sarawak)"|"EB": [6377298.556, 1 / 300.8017] + "Fischer 1960": [6378166.0, 1 / 298.3] + "Fischer 1968": [6378150.0, 1 / 298.3] + "GRS67": [6378160.0, 1 / 298.247167427] + "GRS80"|"NAD83"|"RF": [6378137.0, 1 / 298.257222101] + "Hayford": [6378388.0, 1 / 297.0] + "Helmert 1906"|"HE": [6378200.0, 1 / 298.3] + "Hough"|"HO": [6378270.0, 1 / 297.0] + "Indonesian 1974"|"ID": [6378160.0, 1 / 298.247] + "International 1924"|"IN": [6378388.0, 1 / 297.0] + "Krassovsky 1940"|"KA": [6378245.0, 1 / 298.3] + "Modified Airy"|"AM": [6377340.189, 1 / 299.3249646] + "Modified Fischer 1960"|"FA": [6378155.0, 1 / 298.3] + "South American 1969"|"SA": [6378160.0, 1 / 298.25] + "WGS 1960"|"WGS 60"|"WGS60"|"W60"|"WA": [6378165.0, 1 / 298.3] + "WGS 1966"|"WGS 66"|"WGS66"|"W66"|"WB": [6378145.0, 1 / 298.25] + "WGS 1972"|"WGS 72"|"WGS72"|"W72"|"WD": [6378135.0, 1 / 298.26] + "WGS 1984"|"WGS 84"|"WGS84"|"W84"|"WE": [6378137.0, 1 / 298.257223563] + default: runerr(207, name) + } +end + + + +###################### Datum Parameters ################################# + + +record gdt_datum_rec( + region, # major region of datum (e.g. "Africa") + name, # datum code name + area, # area of datum (e.g. "Cameroon") + eps, # ellipsoid specification (e.g. "CD") + dx, dy, dz, # x,y,z differences from WGS84 + ex, ey, ez # x,y,z maximum error in converted point (unused) + ) + + +procedure gdt_datum_params(codename) + initial gdt_datum_init() + return \gdt_datum_ptab[codename] | runerr(207, codename) +end + + +procedure gdt_datum_add(key, fields[]) + return gdt_datum_ptab[key] := gdt_datum_rec ! fields +end + + +procedure gdt_datum_init() + gdt_datum_ptab := table() + +$define add gdt_datum_add + +# ----------------- AFRICA -------------------------------- +add("ADI-M", "Africa", +"Adindan","mean Ethiopia & Sudan","CD", -166,-15,204, 5,5,3 +) +add("ADI-E", "Africa", +"Adindan","Burkina Faso","CD", -118,-14,218, 25,25,25 +) +add("ADI-F", "Africa", +"Adindan","Cameroon","CD", -134,-2,210, 25,25,25 +) +add("ADI-A", "Africa", +"Adindan","Ethiopia","CD", -165,-11,206, 3,3,3 +) +add("ADI-C", "Africa", +"Adindan","Mali","CD", -123,-20,220, 25,25,25 +) +add("ADI-D", "Africa", +"Adindan","Senegal","CD", -128,-18,224, 25,25,25 +) +add("ADI-B", "Africa", +"Adindan","Sudan","CD", -161,-14,205, 3,5,3 +) +add("AFG", "Africa", +"Afgooye","Somalia","KA", -43,-163,45, 25,25,25 +) +add("ARF-M", "Africa", +"Arc 1950","mean","CD", -143,-90,-294, 20,33,20 +) +add("ARF-A", "Africa", +"Arc 1950","Botswana","CD", -138,-105,-289, 3,5,3 +) +add("ARF-H", "Africa", +"Arc 1950","Burundi","CD", -153,-5,-292, 20,20,20 +) +add("ARF-B", "Africa", +"Arc 1950","Lesotho","CD", -125,-108,-295, 3,3,8 +) +add("ARF-C", "Africa", +"Arc 1950","Malawi","CD", -161,-73,-317, 9,24,8 +) +add("ARF-D", "Africa", +"Arc 1950","Swaziland","CD", -134,-105,-295, 15,15,15 +) +add("ARF-E", "Africa", +"Arc 1950","Zaire","CD", -169,-19,-278, 25,25,25 +) +add("ARF-F", "Africa", +"Arc 1950","Zambia","CD", -147,-74,-283, 21,21,27 +) +add("ARF-G", "Africa", +"Arc 1950","Zimbabwe","CD", -142,-96,-293, 5,8,11 +) +add("ARS-M", "Africa", +"Arc 1960","mean Kenya & Tanzania","CD",-160,-6,-302, 20,20,20 +) +add("ARS-A", "Africa", +"Arc 1960","Kenya","CD", -157,-2,-299, 4,3,3 +) +add("ARS-B", "Africa", +"Arc 1960","Tanzania","CD", -175,-23,-303, 6,9,10 +) +add("PHA", "Africa", +"Ayabelle Lighthouse","Djibouti","CD", -79,-129,145, 25,25,25 +) +add("BID", "Africa", +"Bissau","Guinea-Bissau","IN", -173,253,27, 25,25,25 +) +add("CAP", "Africa", +"Cape","South Africa","CD", -136,-108,-292, 3,6,6 +) +add("CGE", "Africa", +"Carthage","Tunisia","CD", -263,6,431, 6,9,8 +) +add("DAL", "Africa", +"Dabola","Guinea","CD", -83,37,124, 15,15,15 +) +add("EUR-F", "Africa", +"European 1950","Egypt","IN", -130,-117,-151, 6,8,8 +) +add("EUR-T", "Africa", +"European 1950","Tunisia","IN", -112,-77,-145, 25,25,25 +) +add("LEH", "Africa", +"Leigon","Ghana","CD", -130,29,364, 2,3,2 +) +add("LIB", "Africa", +"Liberia 1964","Liberia","CD", -90,40,88, 15,15,15 +) +add("MAS", "Africa", +"Massawa","Eritrea (Ethiopia)","BR", 639,405,60, 25,25,25 +) +add("MER", "Africa", +"Merchich","Morocco","CD", 31,146,47, 5,3,3 +) +add("MIN-A", "Africa", +"Minna","Cameroon","CD", -81,-84,115, 25,25,25 +) +add("MIN-B", "Africa", +"Minna","Nigeria","CD", -92,-93,122, 3,6,5 +) +add("MPO", "Africa", +"M'Poraloko","Gabon","CD", -74,-130,42, 25,25,25 +) +add("NSD", "Africa", +"North Sahara 1959","Algeria","CD", -186,-93,310, 25,25,25 +) +add("OEG", "Africa", +"Old Egyptian 1907","Egypt","HE", -130,110,-13, 3,6,8 +) +add("PTB", "Africa", +"Point 58","mean Burkina Faso & Niger","CD",-106,-129,165, 25,25,25 +) +add("PTN", "Africa", +"Pointe Noire 1948","Congo","CD", -148,51,-291, 25,25,25 +) +add("SCK", "Africa", +"Schwarzeck","Namibia","BN", 616,97,-251, 20,20,20 +) +add("SRL", "Africa", +"Sierra Leone 1960","Sierra Leone","CD", -88,4,101, 15,15,15 +) +add("VOR", "Africa", +"Voirol 1960","Algeria","CD", -123,-206,219, 25,25,25 +) + +# ----------------- ASIA -------------------------------- +add("AIN-A", "Asia", +"Ain el Abd 1970","Bahrain","IN", -150,-250,-1, 25,25,25 +) +add("AIN-B", "Asia", +"Ain el Abd 1970","Saudi Arabia","IN", -143,-236,7, 10,10,10 +) +add("BAT", "Asia", +"Djakarta (Batavia)","Sumatra (Indonesia)","BR",-377,681,-50, 3,3,3 +) +add("EUR-H", "Asia", +"European 1950","Iran","IN", -117,-132,-164, 9,12,11 +) +add("HKD", "Asia", +"Hong Kong 1963","Hong Kong","IN", -156,-271,-189, 25,25,25 +) +add("HTN", "Asia", +"Hu-Tzu-Shan","Taiwan","IN", -637,-549,-203, 15,15,15 +) +add("IND-B", "Asia", +"Indian","Bangladesh","EA", 282,726,254, 10,8,12 +) +add("IND-I", "Asia", +"Indian","India & Nepal","EC", 295,736,257, 12,10,15 +) +add("INF-A", "Asia", +"Indian 1954","Thailand","EA", 217,823,299, 15,6,12 +) +add("ING-A", "Asia", +"Indian 1960","Vietnam (near 16N)","EA",198,881,317, 25,25,25 +) +add("ING-B", "Asia", +"Indian 1960","Con Son Island (Vietnam)","EA",182,915,344, 25,25,25 +) +add("INH-A", "Asia", +"Indian 1975","Thailand","EA", 209,818,290, 12,10,12 +) +add("INH-A1", "Asia", +"Indian 1975","Thailand","EA", 210,814,289, 3,2,3 +) +add("IDN", "Asia", +"Indonesian 1974","Indonesia","ID", -24,-15,5, 25,25,25 +) +add("KAN", "Asia", +"Kandawala","Sri Lanka","EA", -97,787,86, 20,20,20 +) +add("KEA", "Asia", +"Kertau 1948","West Malaysia & Singapore","EE",-11,851,5, 10,8,6 +) +add("KGS", "Asia", +"Korean Geodetic System 1995","South Korea","WE",0,0,0, 1,1,1 +) +add("NAH-A", "Asia", +"Nahrwan","Masirah Island (Oman)","CD", -247,-148,369, 25,25,25 +) +add("NAH-B", "Asia", +"Nahrwan","United Arab Emirates","CD", -249,-156,381, 25,25,25 +) +add("NAH-C", "Asia", +"Nahrwan","Saudi Arabia","CD", -243,-192,477, 20,20,20 +) +add("FAH", "Asia", +"Oman","Oman","CD", -346,-1,224, 3,3,9 +) +add("QAT", "Asia", +"Qatar National","Qatar","IN", -128,-283,22, 20,20,20 +) +add("SOA", "Asia", +"South Asia","Singapore","FA", 7,-10,-26, 25,25,25 +) +add("TIL", "Asia", +"Timbalai 1948","Brunei & East Malaysia (Sarawak & Sabah)","EB", + -679,669,-48, 10,10,12 +) +add("TOY-M", "Asia", +"Tokyo","mean","BR", -148,507,685, 20,5,20 +) +add("TOY-A", "Asia", +"Tokyo","Japan","BR", -148,507,685, 8,5,8 +) +add("TOY-C", "Asia", +"Tokyo","Okinawa","BR", -158,507,676, 20,5,20 +) +add("TOY-B", "Asia", +"Tokyo","South Korea","BR", -146,507,687, 8,5,8 +) +add("TOY-B1", "Asia", +"Tokyo","South Korea","BR", -147,506,687, 2,2,2 +) + +# ----------------- AUSTRALIA -------------------------------- +add("AUA", "Australia", +"Australian Geodetic 1966","Australia & Tasmania","AN",-133,-48,148, 3,3,3 +) +add("AUG", "Australia", +"Australian Geodetic 1984","Australia & Tasmania","AN",-134,-48,149, 2,2,2 +) + +# ----------------- EUROPE -------------------------------- +add("EST", "Europe", +"Co-ordinate System 1937 of Estonia","Estonia","BN",374,150,588, 2,3,3 +) +add("EUR-M", "Europe", +"European 1950","mean","IN", -87,-98,-121, 3,8,5 +) +add("EUR-A", "Europe", +"European 1950","mean Western Europe","IN",-87,-96,-120, 3,3,3 +) +add("EUR-E", "Europe", +"European 1950","Cyprus","IN", -104,-101,-140, 15,15,15 +) +add("EUR-G", "Europe", +"European 1950","England & Channel Islands & Scotland & Shetland Islands","IN", + -86,-96,-120, 3,3,3 +) +add("EUR-K", "Europe", +"European 1950","England & Ireland & Scotland & Shetland Islands","IN", + -86,-96,-120, 3,3,3 +) +add("EUR-B", "Europe", +"European 1950","Greece","IN", -84,-95,-130, 25,25,25 +) +add("EUR-I", "Europe", +"European 1950","Sardinia (Italy)","IN",-97,-103,-120, 25,25,25 +) +add("EUR-J", "Europe", +"European 1950","Sicily (Italy)","IN", -97,-88,-135, 20,20,20 +) +add("EUR-L", "Europe", +"European 1950","Malta","IN", -107,-88,-149, 25,25,25 +) +add("EUR-C", "Europe", +"European 1950","Norway & Finland","IN",-87,-95,-120, 3,5,3 +) +add("EUR-D", "Europe", +"European 1950","Portugal & Spain","IN",-84,-107,-120, 5,6,3 +) +add("EUS", "Europe", +"European 1979","mean","IN", -86,-98,-119, 3,3,3 +) +add("HJO", "Europe", +"Hjorsey 1955","Iceland","IN", -73,46,-86, 3,3,6 +) +add("IRL", "Europe", +"Ireland 1965","Ireland","AM", 506,-122,611, 3,3,3 +) +add("OGB-M", "Europe", +"Ordnance Survey Great Britain 1936","mean","AA",375,-111,431, 10,10,15 +) +add("OGB-A", "Europe", +"Ordnance Survey Great Britain 1936","England","AA",371,-112,434, 5,5,6 +) +add("OGB-B", "Europe", +"Ordnance Survey Great Britain 1936","England & Isle of Man & Wales","AA", + 371,-111,434, 10,10,15 +) +add("OGB-C", "Europe", +"Ordnance Survey Great Britain 1936","Scotland & Shetland Islands","AA", + 384,-111,425, 10,10,10 +) +add("OGB-D", "Europe", +"Ordnance Survey Great Britain 1936","Wales","AA",370,-108,434, 20,20,20 +) +add("MOD", "Europe", +"Rome 1940","Sardinia","IN", -225,-65,9, 25,25,25 +) +add("SPK-A", "Europe", +"S-42 (Pulkovo 1942)","Hungary","KA", 28,-121,-77, 2,2,2 +) +add("SPK-B", "Europe", +"S-42 (Pulkovo 1942)","Poland","KA", 23,-124,-82, 4,2,4 +) +add("SPK-C", "Europe", +"S-42 (Pulkovo 1942)","Czechoslavakia","KA",26,-121,-78, 3,3,2 +) +add("SPK-D", "Europe", +"S-42 (Pulkovo 1942)","Latvia","KA", 24,-124,-82, 2,2,2 +) +add("SPK-E", "Europe", +"S-42 (Pulkovo 1942)","Kazakhstan","KA",15,-130,-84, 25,25,25 +) +add("SPK-F", "Europe", +"S-42 (Pulkovo 1942)","Albania","KA", 24,-130,-92, 3,3,3 +) +add("SPK-G", "Europe", +"S-42 (Pulkovo 1942)","Romania","KA", 28,-121,-77, 3,5,3 +) +add("CCD", "Europe", +"S-JTSK","Czechoslavakia (Prior 1 Jan 1993)","BR",589,76,480, 4,2,3 +) + +# ----------------- NORTH AMERICA -------------------------------- +add("CAC", "North America", +"Cape Canaveral","mean Bahamas & Florida","CC",-2,151,181, 3,3,3 +) +gdt_datum_ptab["NAD27"] := +add("NAS-C", "North America", +"North American 1927","mean CONUS","CC",-8,160,176, 5,5,6 +) +add("NAS-B", "North America", +"North American 1927","mean West CONUS","CC",-8,159,175, 5,3,3 +) +add("NAS-A", "North America", +"North American 1927","mean East CONUS","CC",-9,161,179, 5,5,8 +) +add("NAS-D", "North America", +"North American 1927","Alaska (minus Aleutian Islands)","CC", + -5,135,172, 5,9,5 +) +add("NAS-V", "North America", +"North American 1927","Aleutian Islands East of 180W","CC", + -2,152,149, 6,8,10 +) +add("NAS-W", "North America", +"North American 1927","Aleutian Islands West of 180W","CC", + 2,204,105, 10,10,10 +) +add("NAS-Q", "North America", +"North American 1927","Bahamas (minus San Salvador Island)","CC", + -4,154,178, 5,3,5 +) +add("NAS-R", "North America", +"North American 1927","San Salvador Island","CC",1,140,165, 25,25,25 +) +add("NAS-E", "North America", +"North American 1927","mean Canada","CC",-10,158,187, 15,11,6 +) +add("NAS-F", "North America", +"North American 1927","Albert & British Columbia (Canada)","CC", + -7,162,188, 8,8,6 +) +add("NAS-G", "North America", +"North American 1927","Eastern Canada","CC",-22,160,190, 6,6,3 +) +add("NAS-H", "North America", +"North American 1927","Manitoba & Ontario (Canada)","CC",-9,157,184, 9,5,5 +) +add("NAS-I", "North America", +"North American 1927","Northwest Territories & Saskatchewan (Canada)","CC", + 4,159,188, 5,5,3 +) +add("NAS-J", "North America", +"North American 1927","Yukon (Canada)","CC",-7,139,181, 5,8,3 +) +add("NAS-O", "North America", +"North American 1927","Canal Zone","CC",0,125,201, 20,20,20 +) +add("NAS-P", "North America", +"North American 1927","mean Caribbean","CC",-3,142,183, 3,9,12 +) +add("NAS-N", "North America", +"North American 1927","mean Central America","CC",0,125,194, 8,3,5 +) +add("NAS-T", "North America", +"North American 1927","Cuba","CC", -9,152,178, 25,25,25 +) +add("NAS-U", "North America", +"North American 1927","Greenland (Hayes Peninsula)","CC",11,114,195, 25,25,25 +) +add("NAS-L", "North America", +"North American 1927","Mexico","CC", -12,130,190, 8,6,6 +) +add("NAR-A", "North America", +"North American 1983","Alaska (minus Aleutian Islands)","RF",0,0,0, 2,2,2 +) +add("NAR-E", "North America", +"North American 1983","Aleutian Islands","RF",-2,0,4, 5,2,5 +) +add("NAR-B", "North America", +"North American 1983","Canada","RF", 0,0,0, 2,2,2 +) +gdt_datum_ptab["NAD83"] := +add("NAR-C", "North America", +"North American 1983","CONUS","RF", 0,0,0, 2,2,2 +) +add("NAR-H", "North America", +"North American 1983","Hawaii","RF", 1,1,-1, 2,2,2 +) +add("NAR-D", "North America", +"North American 1983","Mexico & Central America","RF",0,0,0, 2,2,2 +) + +# ----------------- SOUTH AMERICA -------------------------------- +add("BOO", "South America", +"Bogota Observatory","Colombia","IN", 307,304,-318, 6,5,6 +) +add("CAI", "South America", +"Campo Inchauspe 1969","Argentina","IN",-148,136,90, 5,5,5 +) +add("CHU", "South America", +"Chua Astro","Paraguay","IN", -134,229,-29, 6,9,5 +) +add("COA", "South America", +"Corrego Alegre","Brazil","IN", -206,172,-6, 5,3,5 +) +add("PRP-M", "South America", +"Provisional South American 1956","mean","IN",-288,175,-376, 17,27,27 +) +add("PRP-A", "South America", +"Provisional South American 1956","Bolivia","IN",-270,188,-388, 5,11,14 +) +add("PRP-B", "South America", +"Provisional South American 1956","Northern Chile","IN", + -270,183,-390, 25,25,25 +) +add("PRP-C", "South America", +"Provisional South American 1956","Southern Chile","IN", + -305,243,-442, 20,20,20 +) +add("PRP-D", "South America", +"Provisional South American 1956","Colombia","IN",-282,169,-371, 15,15,15 +) +add("PRP-E", "South America", +"Provisional South American 1956","Ecuador","IN",-278,171,-367, 3,5,3 +) +add("PRP-F", "South America", +"Provisional South American 1956","Guyana","IN",-298,159,-369, 6,14,5 +) +add("PRP-G", "South America", +"Provisional South American 1956","Peru","IN",-279,175,-379, 6,8,12 +) +add("PRP-H", "South America", +"Provisional South American 1956","Venezuela","IN",-295,173,-371, 9,14,15 +) +add("HIT", "South America", +"Provisional South Chilean 1963","Southern Chile","IN",16,196,93, 25,25,25 +) +add("SAN-M", "South America", +"South American 1969","mean","SA", -57,1,-41, 15,6,9 +) +add("SAN-A", "South America", +"South American 1969","Argentina","SA", -62,-1,-37, 5,5,5 +) +add("SAN-B", "South America", +"South American 1969","Bolivia","SA", -61,2,-48, 15,15,15 +) +add("SAN-C", "South America", +"South American 1969","Brazil","SA", -60,-2,-41, 3,5,5 +) +add("SAN-D", "South America", +"South American 1969","Chile","SA", -75,-1,-44, 15,8,11 +) +add("SAN-E", "South America", +"South American 1969","Colombia","SA", -44,6,-36, 6,6,5 +) +add("SAN-F", "South America", +"South American 1969","Ecuador (minus Galapagos Islands)","SA", + -48,3,-44, 3,3,3 +) +add("SAN-J", "South America", +"South American 1969","Baltra & Galapagos Islands (Ecuador)","SA", + -47,26,-42, 25,25,25 +) +add("SAN-G", "South America", +"South American 1969","Guyana","SA", -53,3,-47, 9,5,5 +) +add("SAN-H", "South America", +"South American 1969","Paraguay","SA", -61,2,-33, 15,15,15 +) +add("SAN-I", "South America", +"South American 1969","Peru","SA", -58,0,-44, 5,5,5 +) +add("SAN-K", "South America", +"South American 1969","Trinidad & Tobago","SA",-45,12,-33, 25,25,25 +) +add("SAN-L", "South America", +"South American 1969","Venezuela","SA", -45,8,-33, 3,6,3 +) +add("SIR", "South America", +"South American Geocentric Reference System (SIRGAS)","South America","RF", + 0,0,0, 1,1,1 +) +add("ZAN", "South America", +"Zanderij","Suriname","IN", -265,120,-358, 5,5,8 +) + +# ----------------- ATLANTIC OCEAN -------------------------------- +add("AIA", "Atlantic Ocean", +"Antigua Island Astro 1943","Antigua & Leeward Islands","CD", + -270,13,62, 25,25,25 +) +add("ASC", "Atlantic Ocean", +"Ascension Island 1958","Ascension Island","IN",-205,107,53, 25,25,25 +) +add("SHB", "Atlantic Ocean", +"Astro DOS 71/4","St Helena Island","IN",-320,550,-494, 25,25,25 +) +add("BER", "Atlantic Ocean", +"Bermuda 1957","Bermuda","CC", -73,213,296, 20,20,20 +) +add("DID", "Atlantic Ocean", +"Deception Island","Deception Island & Antarctica","CD",260,12,-147, 20,20,20 +) +add("FOT", "Atlantic Ocean", +"Fort Thomas 1955","Nevis & St. Kitts & Leeward Islands","CD", + -7,215,225, 25,25,25 +) +add("GRA", "Atlantic Ocean", +"Graciosa Base SW 1948", +"Faial & Graciosa & Pico & Sao Jorge & Terceira Islands (Azores)","IN", + -104,167,-38, 3,3,3 +) +add("ISG", "Atlantic Ocean", +"ISTS 061 Astro 1968","South Georgia Island","IN",-794,119,-298, 25,25,25 +) +add("LCF", "Atlantic Ocean", +"L. C. 5 Astro 1961","Cayman Brac Island","CC",42,124,147, 25,25,25 +) +add("ASM", "Atlantic Ocean", +"Montserrat Island Astro 1958","Montserrat & Leeward Islands","CD", + 174,359,365, 25,25,25 +) +add("NAP", "Atlantic Ocean", +"Naparima BWI","Trinidad & Tobago","IN",-10,375,165, 15,15,15 +) +add("FLO", "Atlantic Ocean", +"Observatorio Meteorologico 1939","Corvo & Flores Islands (Azores)","IN", + -425,-169,81, 20,20,20 +) +add("PLN", "Atlantic Ocean", +"Pico de las Nieves","Canary Islands","IN",-307,-92,127, 25,25,25 +) +add("POS", "Atlantic Ocean", +"Porto Santo 1936","Porto Santo & Madeira Islands","IN",-499,-249,314, 25,25,25 +) +add("PUR", "Atlantic Ocean", +"Puerto Rico","Puerto Rico & Virgin Islands","CC",11,72,-101, 3,3,3 +) +add("QUO", "Atlantic Ocean", +"Qornoq","South Greenland","IN", 164,138,-189, 25,25,32 +) +add("SAO", "Atlantic Ocean", +"Sao Braz","Sao Miguel & Santa Maria Islands","IN",-203,141,53, 25,25,25 +) +add("SAP", "Atlantic Ocean", +"Sapper Hill 1943","East Falkland Island","IN",-355,21,72, 1,1,1 +) +add("SGM", "Atlantic Ocean", +"Selvagem Grande 1938","Salvage Islands","IN",-289,-124,60, 25,25,25 +) +add("TDC", "Atlantic Ocean", +"Tristan Astro 1968","Tristan da Cunha","IN",-632,438,-609, 25,25,25 +) + +# ----------------- INDIAN OCEAN -------------------------------- +add("ANO", "Indian Ocean", +"Anna 1 Astro 1965","Cocos Islands","AN",-491,-22,435, 25,25,25 +) +add("GAA", "Indian Ocean", +"Gan 1970","Republic of Maldives","IN", -133,-321,50, 25,25,25 +) +add("IST", "Indian Ocean", +"ISTS 073 Astro 1969","Diego Garcia","IN",208,-435,-229, 25,25,25 +) +add("KEG", "Indian Ocean", +"Kerguelen Island 1949","Kerguelen Island","IN",145,-187,103, 25,25,25 +) +add("MIK", "Indian Ocean", +"Mahe 1971","Mahe Island","CD", 41,-220,-134, 25,25,25 +) +add("REU", "Indian Ocean", +"Reunion","Mascarene Islands","IN", 94,-948,-1262, 25,25,25 +) + +# ----------------- PACIFIC OCEAN -------------------------------- +add("AMA", "Pacific Ocean", +"American Samoa 1962","American Samoa Islands","CC",-115,118,426, 25,25,25 +) +add("ATF", "Pacific Ocean", +"Astro Beacon E 1945","Iwo Jima","IN", 145,75,-272, 25,25,25 +) +add("TRN", "Pacific Ocean", +"Astro Tern Island (FRIG) 1961","Tern Island","IN",114,-116,-333, 25,25,25 +) +add("ASQ", "Pacific Ocean", +"Astronomical Station 1952","Marcus Island","IN",124,-234,-25, 25,25,25 +) +add("IBE", "Pacific Ocean", +"Bellevue (IGN)","Efate & Erromango Islands","IN",-127,-769,472, 20,20,20 +) +add("CAO", "Pacific Ocean", +"Canton Astro 1966","Phoenix Islands","IN",298,-304,-375, 15,15,15 +) +add("CHI", "Pacific Ocean", +"Chatham Island Astro 1971","Chatham Island (New Zealand)","IN", + 175,-38,113, 15,15,15 +) +add("GIZ", "Pacific Ocean", +"DOS 1968","Gizo Island (New Georgia Islands)","IN",230,-199,-752, 25,25,25 +) +add("EAS", "Pacific Ocean", +"Easter Island 1967","Easter Island","IN",211,147,111, 25,25,25 +) +add("GEO", "Pacific Ocean", +"Geodetic Datum 1949","New Zealand","IN",84,-22,209, 5,3,5 +) +add("GUA", "Pacific Ocean", +"Guam 1963","Guam","CC", -100,-248,259, 3,3,3 +) +add("DOB", "Pacific Ocean", +"GUX 1 Astro","Guadalcanal Island","IN",252,-209,-751, 25,25,25 +) +add("JOH", "Pacific Ocean", +"Johnston Island 1961","Johnston Island","IN",189,-79,-202, 25,25,25 +) +add("KUS", "Pacific Ocean", +"Kusaie Astro 1951","Caroline Islands & Fed. States of Micronesia","IN", + 647,1777,-1124, 25,25,25 +) +add("LUZ-A", "Pacific Ocean", +"Luzon","Philippines (minus Mindanao Island)","CC",-133,-77,-51, 8,11,9 +) +add("LUZ-B", "Pacific Ocean", +"Luzon","Mindanao Island (Philippines)","CC",-133,-79,-72, 25,25,25 +) +add("MID", "Pacific Ocean", +"Midway Astro 1961","Midway Islands","IN",912,-58,1227, 25,25,25 +) +add("OHA-M", "Pacific Ocean", +"Old Hawaiian","mean","CC", 61,-285,-181, 25,20,20 +) +add("OHA-A", "Pacific Ocean", +"Old Hawaiian","Hawaii","CC", 89,-279,-183, 25,25,25 +) +add("OHA-B", "Pacific Ocean", +"Old Hawaiian","Kauai","CC", 45,-290,-172, 20,20,20 +) +add("OHA-C", "Pacific Ocean", +"Old Hawaiian","Maui","CC", 65,-290,-190, 25,25,25 +) +add("OHA-D", "Pacific Ocean", +"Old Hawaiian","Oahu","CC", 58,-283,-182, 10,6,6 +) +add("OHI-M", "Pacific Ocean", +"Old Hawaiian Int","mean","IN", 201,-228,-346, 25,20,20 +) +add("OHI-A", "Pacific Ocean", +"Old Hawaiian Int","Hawaii","IN", 229,-222,-348, 25,25,25 +) +add("OHI-B", "Pacific Ocean", +"Old Hawaiian Int","Kauai","IN", 185,-233,-337, 20,20,20 +) +add("OHI-C", "Pacific Ocean", +"Old Hawaiian Int","Maui","IN", 205,-233,-355, 25,25,25 +) +add("OHI-D", "Pacific Ocean", +"Old Hawaiian Int","Oahu","IN", 198,-226,-347, 10,6,6 +) +add("PIT", "Pacific Ocean", +"Pitcairn Astro 1967","Pitcairn Island","IN",185,165,42, 25,25,25 +) +add("SAE", "Pacific Ocean", +"Santo (DOS) 1965","Espirito Santo Island","IN",170,42,84, 25,25,25 +) +add("MVS", "Pacific Ocean", +"Viti Levu 1916","Viti Levu Island (Fiji Islands)","CD",51,391,-36, 25,25,25 +) +add("ENW", "Pacific Ocean", +"Wake-Eniwetok 1960","Marshall Islands","HO",102,52,-38, 3,3,3 +) +add("WAK", "Pacific Ocean", +"Wake Island Astro 1952","Wake Atoll","IN",276,-57,149, 25,25,25 +) + +# ----------------- WORLD-WIDE DATUM ---------------------------- +gdt_datum_ptab["WGS66"] := +add("W66", "World-wide Datum", +"WGS 1966","Global Definition I","WB", 0,0,0, 0,0,0 +) +gdt_datum_ptab["WGS72"] := +add("W72", "World-wide Datum", +"WGS 1972","Global Definition I","WD", 0,0,0, 3,3,3 +) +gdt_datum_ptab["WGS84"] := +add("W84", "World-wide Datum", +"WGS 1984","Global Definition II","WE", 0,0,0, 0,0,0 +) + +# ----------------- MISC. NON-SATELLITE DERIVED ---------------------------- +# Error bounds of zero mean unknown error. +add("BUR", "Misc. Non-satellite derived", +"Bukit Rimpah","Bangka & Belitung Islands (Indonesia)","BR",-384,664,-48, 0,0,0 +) +add("CAZ", "Misc. Non-satellite derived", +"Camp Area Astro","Camp McMurdo Area (Antarctica)","IN",-104,-129,239, 0,0,0 +) +add("EUR-S", "Misc. Non-satellite derived", +"European 1950","mean Near East","IN", -103,-106,-141, 0,0,0 +) +add("GSE", "Misc. Non-satellite derived", +"Gunung Segara","Kalimantan (Indonesia)","BR",-403,684,41, 0,0,0 +) +add("HEN", "Misc. Non-satellite derived", +"Herat North","Afghanistan","IN", -333,-222,114, 0,0,0 +) +add("HER", "Misc. Non-satellite derived", +"Hermannskogel", +"Yugoslavia (Prior to 1990) Slovenia & Croatia & Bosnia & Herzegovina & Serbia", +"BN", 682,-203,480, 0,0,0 +) +add("IND-P", "Misc. Non-satellite derived", +"Indian","Pakistan","EF", 283,682,231, 0,0,0 +) +add("PUK", "Misc. Non-satellite derived", +"Pulkovo 1942","Russia","KA", 28,-130,-95, 0,0,0 +) +add("TAN", "Misc. Non-satellite derived", +"Tananarive Observatory 1925","Madagascar","IN",-189,-242,-91, 0,0,0 +) +add("VOI", "Misc. Non-satellite derived", +"Voirol 1874","Tunisia & Algeria","CD", -73,-247,227,0,0,0 +) +add("YAC", "Misc. Non-satellite derived", +"Yacare","Uruguay","IN", -155,171,37, 0,0,0 +) +return +end diff --git a/ipl/procs/getchlib.icn b/ipl/procs/getchlib.icn new file mode 100644 index 0000000..e4ee2cc --- /dev/null +++ b/ipl/procs/getchlib.icn @@ -0,0 +1,338 @@ +############################################################################ +# +# File: getchlib.icn +# +# Subject: Procedures for getch for UNIX +# +# Author: Richard L. Goerwitz +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.14 +# +############################################################################ +# +# Implementing getch() is a much, much more complex affair under UNIX +# than it is under, say, MS-DOS. This library represents one, +# solution to the problem - one which can be run as a library, and +# need not be compiled into the run-time system. Note that it will +# not work on all systems. In particular, certain Suns (with a +# screwy stty command) and the NeXT 1.0 OS (lacking the -g option for +# stty) do not run getchlib properly. See the bugs section below for +# workarounds. +# +# Four basic utilities are included here: +# +# getch() - waits until a keystroke is available & +# returns it without displaying it on the screen +# getche() - same as getch() only with echo +# getse(s) - like getche() only for strings. The optional +# argument s gives getse() something to start with. Use this +# if, say, you want to read single characters in cbreak mode, +# but get more input if the character read is the first part +# of a longer command. If the user backspaces over everything +# that has been input, getse() fails. Returns on \r or \n. +# reset_tty() - absolutely vital routine for putting the cur- +# rent tty line back into cooked mode; call it before exiting +# or you will find yourself with a locked-up terminal; use it +# also if you must temporarily restore the terminal to cooked +# mode +# +# Note that getse() *must* be used in place of read(&input) if you +# are planning on using getch() or getche(), since read(&input) +# assumes a tty with "sane" settings. +# +# Warning: The routines below do not do any sophisticated output +# processing. As noted above, they also put your tty line in raw +# mode. I know, I know: "Raw is overkill - use cbreak." But in +# a world that includes SysV, one must pick a lowest common denomi- +# nator. And no, icanon != cbreak. +# +# BUGS: These routines will not work on systems that do not imple- +# ment the -g option for the stty command. The NeXT workstation is +# an example of such a system. Tisk, tisk. If you are on a BSD +# system where the network configuration makes stty | more impossible, +# then substitute /usr/5bin/stty (or whatever your system calls the +# System V stty command) for /bin/stty in this file. If you have no +# SysV stty command online, then you can try replacing every instance +# of "stty -g 2>&1" below with "stty -g 2>&1 1> /dev/tty" or +# something similar. +# +############################################################################ +# +# Example program: +# +# The following program is a simple file viewer. To run, it +# needs to be linked with itlib.icn, iscreen.icn, and this file +# (getchlib.icn). +# +# procedure main(a) +# +# # Simple pager/file searcher for UNIX systems. Must be linked +# # with itlib.icn and iscreen.icn. +# +# local intext, c, s +# +# # Open input file +# intext := open(a[1],"r") | { +# write(&errout,"Can't open input file.") +# exit(1) +# } +# +# # Initialize screen +# clear() +# print_screen(intext) | exit(0) +# +# # Prompt & read input +# repeat { +# iputs(igoto(getval("cm"), 1, getval("li"))) +# emphasize() +# writes("More? (y/n or /search):") +# write_ce(" ") +# case c := getche() of { +# "y" : print_screen(intext) | break +# " " : print_screen(intext) | break +# "n" : break +# "q" : break +# "/" : { +# iputs(igoto(getval("cm"), 1, getval("li"))) +# emphasize() +# writes("Enter search string:") +# write_ce(" ") +# pattern := GetMoreInput() +# /pattern | "" == pattern & next +# # For more complex patterns, use findre() (IPL findre.icn) +# if not find(pattern, s := !intext) then { +# iputs(igoto(getval("cm"), 1, getval("li"))) +# emphasize() +# write_ce("String not found.") +# break +# } +# else print_screen(intext, s) | break +# } +# } +# } +# +# reset_tty() +# write() +# exit(0) +# +# end +# +# procedure GetMoreInput(c) +# +# local input_string +# static BS +# initial BS := getval("bc") | "\b" +# +# /c := "" +# if any('\n\r', chr := getch()) +# then return c +# else { +# chr == BS & fail +# writes(chr) +# input_string := getse(c || chr) | fail +# if any('\n\r', input_string) +# then fail else (return input_string) +# } +# +# end +# +# procedure print_screen(f,s) +# +# if /s then +# begin := 1 +# # Print top line, if one is supplied +# else { +# iputs(igoto(getval("cm"), 1, 1)) +# write_ce(s ? tab(getval("co") | 0)) +# begin := 2 +# } +# +# # Fill the screen with lines from f; clear and fail on EOF. +# every i := begin to getval("li") - 1 do { +# iputs(igoto(getval("cm"), 1, i)) +# if not write_ce(read(f) ? tab(getval("co") | 0)) then { +# # Clear remaining lines on the screen. +# every j := i to getval("li") do { +# iputs(igoto(getval("cm"), 1, j)) +# iputs(getval("ce")) +# } +# iputs(igoto(getval("cm"), 1, i)) +# fail +# } +# } +# return +# +# end +# +# procedure write_ce(s) +# +# normal() +# iputs(getval("ce")) | +# writes(repl(" ",getval("co") - *s)) +# writes(s) +# return +# +# end +# +############################################################################ +# +# Requires: UNIX +# +############################################################################ +# +# Links: itlib +# +############################################################################ + +link itlib + +global c_cc, current_mode # what mode are we in, raw or cooked? +record termio_struct(vintr,vquit,verase,vkill) + +procedure getse(s) + + # getse() - like getche, only for strings instead of single chars + # + # This procedure *must* be used instead of read(&input) if getch + # and/or getche are to be used, since these put the current tty + # line in raw mode. + # + # Note that the buffer can be initialized by calling getse with a + # string argument. Note also that, as getse now stands, it will + # fail if the user backspaces over everything that has been input. + # This change does not coincide with its behavior in previous ver- + # sions. It can be changed by commenting out the line "if *s < 1 + # then fail" below, and uncommenting the line "if *s < 1 then + # next." + + local chr + static BS + initial { + BS := getval("bc") | "\b" + if not getval("bs") then { + reset_tty() + stop("Your terminal can't backspace!") + } + } + + /s := "" + repeat { + case chr := getch() | fail of { + "\r"|"\n" : return s + c_cc.vkill : { + if *s < 1 then next + every 1 to *s do writes(BS) + s := "" + } + c_cc.verase : { + # if *s < 1 then next + writes(BS) & s := s[1:-1] + if *s < 1 then fail + } + default: writes(chr) & s ||:= chr + } + } + +end + + + +procedure setup_tty() + change_tty_mode("setup") + return +end + + + +procedure reset_tty() + + # Reset (global) mode switch to &null to show we're in cooked mode. + current_mode := &null + change_tty_mode("reset") + return + +end + + + +procedure getch() + + local chr + + # If the global variable current_mode is null, then we have to + # reset the terminal to raw mode. + if /current_mode := 1 then + setup_tty() + + chr := reads(&input) + case chr of { + c_cc.vintr : reset_tty() & stop() # shouldn't hard code this in + c_cc.vquit : reset_tty() & stop() + default : return chr + } + +end + + + +procedure getche() + + local chr + + # If the global variable current_mode is null, then we have to + # reset the terminal to raw mode. + if /current_mode := 1 then + setup_tty() + + chr := reads(&input) + case chr of { + c_cc.vintr : reset_tty() & stop() + c_cc.vquit : reset_tty() & stop() + default : writes(chr) & return chr + } + +end + + + +procedure change_tty_mode(switch) + + # global c_cc (global record containing values for kill, etc. chars) + local get_term_params, i + static reset_string + initial { + getval("li") # check to be sure itlib is set up + find("unix",map(&features)) | + stop("change_tty_mode: These routines must run under UNIX.") + get_term_params := open("/bin/stty -g 2>&1","pr") + reset_string := !get_term_params + close(get_term_params) + reset_string ? { + # tab upto the fifth field of the output of the stty -g cmd + # fields of stty -g seem to be the same as those of the + # termio struct, except that the c_line field is missing + every 1 to 4 do tab(find(":")+1) + c_cc := termio_struct("\x03","\x1C","\x08","\x15") + every i := 1 to 3 do { + c_cc[i] := char(integer("16r"||tab(find(":")))) + move(1) + } + c_cc[i+1] := char(integer("16r"||tab(0))) + } + } + + if switch == "setup" + then system("/bin/stty -echo raw") + else system("/bin/stty "||reset_string) + + return + +end diff --git a/ipl/procs/getkeys.icn b/ipl/procs/getkeys.icn new file mode 100644 index 0000000..30599f6 --- /dev/null +++ b/ipl/procs/getkeys.icn @@ -0,0 +1,83 @@ +############################################################################ +# +# File: getkeys.icn +# +# Subject: Procedures to get keys for a gettext file +# +# Author: Richard L. Goerwitz +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.2 +# +############################################################################ +# +# Getkeys(FNAME) generates all keys in FNAME in order of occurrence. +# See gettext.icn for a description of the requisite file structure +# for FNAME. +# +############################################################################ +# +# Requires: UNIX (maybe MS-DOS; untested) +# +############################################################################ +# +# See also: gettext.icn +# +############################################################################ +# +# Links: adjuncts +# +############################################################################ + +link adjuncts + +global _slash, baselen + +procedure getkeys(FNAME) + + local line, intext, start_unindexed_part + initial { + if /_slash then { + if find("UNIX"|"Amiga", &features) then { + _slash := "/" + _baselen := 10 + } + else if find("MS-DOS", &features) then { + _slash := "\\" + _baselen := 8 + } + else stop("getkeys: OS not supported") + } + } + + /FNAME & stop("error (getkeys): null argument") + + # Try to open index file (there may not be one). + if intext := open(Pathname(FNAME) || getidxname(FNAME)) then { + # If there's an index file, then just suspend all the keys in + # it (i.e. suspend every line except the first, upto the tab). + # The first line tells how many bytes in FNAME were indexed. + # save it, and use it to seek to unindexed portions later on. + start_unindexed_part := integer(read(intext)) + while line := read(intext) do + line ? suspend tab(find("\t")) \ 1 + close(intext) + } + + intext := open(FNAME) | stop("getkeys: ",FNAME," not found") + seek(intext, \start_unindexed_part | 1) + while line := read(intext) do + line ? { suspend (="::", tab(0)) \ 1 } + + # Nothing left to suspend, so fail. + fail + +end + diff --git a/ipl/procs/getmail.icn b/ipl/procs/getmail.icn new file mode 100644 index 0000000..f7431b9 --- /dev/null +++ b/ipl/procs/getmail.icn @@ -0,0 +1,385 @@ +############################################################################ +# +# File: getmail.icn +# +# Subject: Procedure to parse mail file +# +# Author: Charles Shartsis +# +# Date: August 19, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# The getmail procedure reads a Unix/Internet type mail folder +# and generates a sequence of records, one per mail message. +# It fails when end-of-file is reached. Each record contains the +# message header and message text components parsed into separate +# record fields. The entire uninterpreted message (header and text) +# are also stored in the record. See the description +# of message_record below. +# +# The argument to getmail is either the name of a mail folder or +# the file handle for a mail folder which has already been opened +# for reading. If getmail is resumed after the last message is +# generated, it closes the mail folder and returns failure. +# +# If getmail generates an incomplete sequence (does not close the +# folder and return failure) and is then restarted (not resumed) +# on the same or a different mail folder, the previous folder file +# handle remains open and inaccessible. This may be a problem if +# done repeatedly since there is usually an OS-imposed limit +# on number of open file handles. Safest way to use getmail +# is using one of the below forms: +# +# message := message_record() +# every message := !getmail("folder_name") do { +# +# process message ... +# +# } +# +# message := message_record() +# coex := create getmail("folder_name") +# while message := @coex do { +# +# process message ... +# +# } +# +# Note that if message_record's are stored in a list, the records +# may be sorted by individual components (like sender, _date, _subject) +# using sortf function in Icon Version 9.0. +# +############################################################################ +# +# Requires: Icon Version 9 or greater +# +############################################################################ + +record message_record( + + # components of "From " line + sender, # E-Mail address of sender + dayofweek, + month, + day, + time, + year, + + # selected message header fields + + # The following record fields hold the contents of common + # message header fields. Each record field contains the + # corresponding message field's body (as a string) or a null indicating + # that no such field was present in the header. + # Note that a list of message_record's + # can be sorted on any of these fields using the sortff function. + # The record field name is related to the message header field name + # in the following way: + # + # record_field_name := "_" || + # map(message_header_field_name, &ucase || "-", &lcase || "_") + # + # Thus the "Mime-Version" field body is stored in the _mime_version + # record field. Multiline message header fields are "unfolded" + # into a single line according to RFC 822. The message field + # name, the following colon, and any immediately following + # whitespace are stripped from the beginning of the + # record field. E.g., if a header contains + # + # Mime-Version: 1.0 + # + # then + # + # message._mime_version := "1.0" + # + # The "Received:" field is handled differently from the other + # fields since there are typically multiple occurrences of it + # in the same header. The _received record field is either null or + # contains a list of "Received:" fields. The message field names + # are NOT stripped off. Thus + # + # Received: from relay4.UU.NET by mail.netcom.com (8.6.12/Netcom) + # id PAA10801; Sun, 28 May 1995 15:24:17 -0700 + # Received: from alterdial.UU.NET by relay4.UU.NET with SMTP + # id QQyrsr05731; Sun, 28 May 1995 18:17:45 -0400 + # + # get stored as: + # message._received := + # ["Received: from relay4.UU.NET by mail.netcom.com (8.6.12/Netcom) id etc...", + # "Received: from alterdial.UU.NET by relay4.UU.NET with SMTP id etc..."] + + _return_path, + _received, + _date, + _message_id, + _x_sender, + _x_mailer, + _mime_version, + _content_type, + _to, + _from, + _subject, + _status, + _x_status, + _path, + _xref, + _references, + _errors_to, + _x_lines, + _x_vm_attributes, + _reply_to, + _newsgroups, + _content_length, + + # The "other" field gets all the message header fields for which we have not set up + # a specific record field. The "other" record field either contains null + # or a list of header fields not stored in the previous fields. + # Message field names are NOT stripped off field bodies before being stored. + # If there are multiple occurrences of the previously selected fields + # (except _received which is assumed to occur multiple times), then + # the first occurrence is stored in the appropriate record field from + # the list above while subsequent occurences in the same header are + # stored as separate list elements in the "other" record field. + # E.g., the following header fields: + # + # ... + # Whatever: Hello + # Status: RO + # Status: XX + # Status: YY + # ... + # + # would be stored as + # + # message._status := "RO" + # message.other := + # [..., "Whatever: Hello", "Status: XX", "Status: YY", ...] + + other, + + # The message text + # This field is either null or a list of lines comprising + # the message text. + message_text, + + # The entire message - header and text + # This field contains a list of uninterpreted lines (no RFC 822 unfolding) + # comprising the raw message. + + all + +) + +# getmail SEQ +procedure getmail(folder_name) + + local folder, line, message, ws, item_tag, first_item_value, tag_field + local time, message_text, unfolded_line + + ws := ' \t' + + if type(folder_name) == "file" then + folder := folder_name + else + folder := open(folder_name, "r") | + stop("Could not open ", folder_name) + line := read(folder) | &null + + # body ITR UNTIL EOF + until /line do { + # message SEQ + message := message_record() + every !message := &null + # header SEQ + # from-line SEQ + message.all := [] + put(message.all, line) + line ? ( + ="From" & tab(many(ws)) & + message.sender <- tab(many(~ws)) & tab(many(ws)) & + message.dayofweek <- tab(many(&letters)) & tab(many(ws)) & + message.month <- tab(many(&letters)) & tab(many(ws)) & + message.day <- tab(many(&digits)) & tab(many(ws)) & + message.time <- match_time() & tab(many(ws)) & + message.year <- match_year() + ) | + stop("Invalid first message header line:\n", line) + line := read(folder) | &null + # from-line END + # header-fields ITR UNTIL EOF or blank-line or From line + until /line | line == "" | is_From_line(line) do { + # header-field SEQ + # first-line SEQ + put(message.all, line) + # process quoted EOL character + if line[-1] == "\\" then + line[-1] := "\n" + unfolded_line := line + line := read(folder) | &null + # first-line END + # after-lines ITR UNTIL EOF or line doesn't start with ws or + # blank-line or From line + until /line | not any(ws, line) | line == "" | is_From_line(line) do { + # after-line SEQ + put(message.all, line) + # process quoted EOL character + if line[-1] == "\\" then + line[-1] := "\n" + if unfolded_line[-1] == "\n" then + line[1] := "" + unfolded_line ||:= line + line := read(folder) | &null + # after-line END + # after-lines END + } + process_header_field(message, unfolded_line) + # header-field END + # header-fields END + } + # header END + # post-header ALT if blank line + if line == "" then { + # optional-message-text SEQ + # blank-line SEQ + put(message.all, line) + line := read(folder) | &null + # blank-line END + # message-text ITR UNTIL EOF or From line + until /line | is_From_line(line) do { + # message-text-line SEQ + put(message.all, line) + /message.message_text := [] + put(message.message_text, line) + line := read(folder) | &null + # message-text-line END + # message-text END + } + # optional-message-text END + # post-header ALT default + } else { + # post-header END + } + suspend message + # message END + # body END + } + + if folder ~=== &input then + close(folder) +# getmail END +end + +############################################################################# +# procedure is_From_line +############################################################################# + +procedure is_From_line(line) + + return line ? ="From " + +end + +############################################################################# +# procedure match_time +############################################################################# + +procedure match_time() + + suspend tab(any(&digits)) || tab(any(&digits)) || =":" || + tab(any(&digits)) || tab(any(&digits)) || =":" || + tab(any(&digits)) || tab(any(&digits)) + +end + +############################################################################# +# procedure match_year +############################################################################# + +procedure match_year() + + suspend tab(any(&digits)) || tab(any(&digits)) || + tab(any(&digits)) || tab(any(&digits)) + +end + +############################################################################# +# procedure mfield_to_rfield_name +############################################################################# + +procedure mfield_to_rfield_name(mfield_name) + + static mapfrom, mapto + + initial { + mapfrom := &ucase || "-" + mapto := &lcase || "_" + } + + return "_" || map(mfield_name, mapfrom, mapto) + +end + +############################################################################# +# procedure process_header_field +############################################################################# + +procedure process_header_field(message, field) + + local record_field_name, header_field_name, field_body + static field_chars, ws + + # header field name can have ASCII 33 through 126 except for colon + initial { + field_chars := cset(string(&ascii)[34:-1]) -- ':' + ws := ' \t' + } + + field ? ( + header_field_name <- tab(many(field_chars)) & =":" & + (tab(many(ws)) | "") & + field_body <- tab(0) + ) | + stop("Invalid header field:\n", field) + record_field_name := mfield_to_rfield_name(header_field_name) + + # This is one of the selected fields + if message[record_field_name] then { + + # Its a "Received" field + if record_field_name == "_received" then { + # Append whole field to received field list + /message._received := [] + put(message._received, field) + + # Not a "Received" field + } else { + + # First occurrence in header of selected field + if /message[record_field_name] then { + # Assign field body to selected record field + message[record_field_name] := field_body + + # Subsequent occurrence in header of selected field + } else { + # Append whole field to other field list + /message.other := [] + put(message.other, field) + } + } + + # Not a selected field + } else { + # Append whole field to other field list + /message.other := [] + put(message.other, field) + } + +end + +############################################################################# + diff --git a/ipl/procs/getpaths.icn b/ipl/procs/getpaths.icn new file mode 100644 index 0000000..0e91d98 --- /dev/null +++ b/ipl/procs/getpaths.icn @@ -0,0 +1,64 @@ +############################################################################ +# +# File: getpaths.icn +# +# Subject: Procedure to generate elements in path +# +# Author: Richard L. Goerwitz +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.3 +# +############################################################################ +# +# Suspends, in turn, the paths supplied as args to getpaths(), +# then all paths in the PATH environment variable. A typical +# invocation might look like: +# +# open(getpaths("/usr/local/lib/icon/procs") || filename) +# +# Note that getpaths() will be resumed in the above context until +# open succeeds in finding an existing, readable file. Getpaths() +# can take any number of arguments. +# +############################################################################ +# +# Requires: UNIX or MS-DOS +# +############################################################################ + +procedure getpaths(base_paths[]) + + local paths, p + static sep, trailer, trimmer + initial { + if find("UNIX", &features) then { + sep := ":" + trailer := "/" + trimmer := cset(trailer || " ") + } + else if find("MS-DOS", &features) then { + sep := ";" + trailer := "\\" + trimmer := cset(trailer || " ") + } + else stop("getpaths: OS not supported.") + } + + suspend !base_paths + paths := getenv("PATH") + \paths ? { + tab(match(sep)) + while p := 1(tab(find(sep)), move(1)) + do suspend ("" ~== trim(p,trimmer)) || trailer + return ("" ~== trim(tab(0),trimmer)) || trailer + } + +end diff --git a/ipl/procs/gettext.icn b/ipl/procs/gettext.icn new file mode 100644 index 0000000..0ed0d3f --- /dev/null +++ b/ipl/procs/gettext.icn @@ -0,0 +1,265 @@ +############################################################################ +# +# File: gettext.icn +# +# Subject: Procedures for gettext (simple text-base routines) +# +# Author: Richard L. Goerwitz +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# History: +# Version 1.19: December 28, 1993 (plt) +# Tested with DOS, DOS-386, OS/2, ProIcon, UNIX +# Modified link and OS statements. +# Open index file in untranslated mode for +# MS-DOS and OS/2 -- ignored by UNIX and Amiga +# Handle multiple, indexed citations. +# Change delimiter from <TAB> to char(255). +# Simplified binary search. +# Version 1.20: August 5, 1995 (plt) +# Replace link statement with preprocessor include. +# Retrieve text for multiple keys on the same line. +# Correct debug printout of indexed and sequential +# search values. +# +############################################################################ +# +# Version: 1.19 December 28, 1993 - Phillip Lee Thomas +# Version: 1.20 August 5, 1995 - plt +# +############################################################################ +# +# Gettext() and associated routines allow the user to maintain a file +# of KEY/value combinations such that a call to gettext(KEY, FNAME) +# will produce value. Gettext() fails if no such KEY exists. +# Returns an empty string if the key exists, but has no associated +# value in the file, FNAME. +# +# The file format is simple. Keys belong on separate lines, marked +# as such by an initial colon+colon (::). Values begin on the line +# following their respective keys, and extend up to the next +# colon+colon-initial line or EOF. E.g. +# +# ::sample.1 +# or: +# ::sample.1 ::sample.2 +# +# Notice how the key above, sample.1, has :: prepended to mark it +# out as a key. The text you are now reading represents that key's +# value. To retrieve this text, you would call gettext() with the +# name of the key passed as its first argument, and the name of the +# file in which this text is stored as its second argument (as in +# gettext("sample.1","tmp.idx")). +# ::next.key +# etc... +# +# For faster access, an indexing utility is included, idxtext. Idxtext +# creates a separate index for a given text-base file. If an index file +# exists in the same directory as FNAME, gettext() will make use of it. +# The index becomes worthwhile (at least on my system) after the text- +# base file becomes longer than 5 kilobytes. +# +# Donts: +# 1) Don't nest gettext text-base files. +# 2) In searches, surround phrases with spaces or tabs in +# key names with quotation marks: "an example" +# 3) Don't modify indexed files in any way other than to append +# additional keys/values (unless you want to re-index). +# +# This program is intended for situations where keys tend to have +# very large values, and use of an Icon table structure would be +# unwieldy. +# +# BUGS: Gettext() relies on the Icon runtime system and the OS to +# make sure the last text/index file it opens gets closed. +# +############################################################################ +# +# Links: adjuncts +# +############################################################################ +# +# Invoke set_OS() before first call to gettext() or +# sequential_search() +# +# Tested with UNIX, OS/2, DOS, DOS-386, ProIcon +# +############################################################################ + +link adjuncts + +global _slash, _baselen, _delimiter + +procedure gettext(KEY,FNAME) #: search database by indexed term + + local line, value + static last_FNAME, intext, inidx, off_set, off_sets + + (/KEY | /FNAME) & stop("error (gettext): null argument") + + if FNAME == \last_FNAME then { + seek(intext, 1) + seek(\inidx, 1) + } + else { + # We've got a new text-base file. Close the old one. + every close(\intext | \inidx) + # Try to open named text-base file. + intext := open(FNAME) | stop("gettext: file \"",FNAME,"\" not found") + # Try to open index file. + inidx := open(Pathname(FNAME) || getidxname(FNAME),"ru") | &null + } + last_FNAME := FNAME + + # Find offsets, if any, for key KEY in index file. + # Then seek to the end and do a sequential search + # for any key/value entries that have been added + # since the last time idxtext was run. + + if off_sets := get_offsets(KEY, inidx) then { + off_sets ? { + while off_set := (move(1),tab(many(&digits))) do { + seek(intext, off_set) + + # Find key. Should be right there, unless the user has appended + # key/value pairs to the end without re-indexing, or else has not + # bothered to index in the first place. In this case we're + # supposed to start a sequential search for KEY upto EOF. + + while line := (read(intext) | fail) do { + line ? { + if (="::",KEY) + then break + } + } + + # Collect all text upto the next colon+colon line (::) + # or EOF. + value := "" + while line := read(intext) do { + find("::",line) & break + value ||:= line || "\n" + } + + # Note that a key with an empty value returns an empty string. + suspend trim(value, '\n') || " (" || off_set || "-i)" + } + } + } + + # Find additional values appended to file since last indexing. + + seek(intext, \firstline - _OS_offset) + while value := sequential_search(KEY, intext) do + suspend trim(value,'\n') #|| " (" || off_set || "-s)" + +end + +procedure get_offsets(KEY, inidx) #: binary search of index + local incr, bottom, top, loc, firstpart, offset, line + + # Use these to store values likely to be reused. + static old_inidx, SOF, EOF + + # If there's no index file, then fail. + if /inidx then + fail + + # First line contains offset of last indexed byte in the main + # text file. We need this later. Save it. Start the binary + # search routine at the next byte after this line. + + seek(inidx, 1) + if not (inidx === \old_inidx) then { + + # Get first line. + firstline := !inidx + + # Set "bottom." + SOF := 1 + + # How big is this file? + seek(inidx, 0) + EOF := where(inidx) + + old_inidx := inidx + } + + # SOF, EOF constant for a given inidx file. + bottom := SOF ; top := EOF + + + # If bottom gets bigger than top, there's no such key. + until bottom >= top do { + + loc := (top+bottom) / 2 + seek(inidx, loc) + + # Move past next newline. If at EOF, break. + + read(inidx) + if (where(inidx) > EOF) | (loc = bottom) | (loc = top) then { + break + } + + # Check to see if the current line contains KEY. + if line := read(inidx) then { + line ? { + + # .IDX file line format is KEY<delimiter>offset + firstpart := tab(upto(_delimiter)) + + if KEY == firstpart then { + # return offset and addresses for any added material + return tab(1 - _OS_offset) + } + + # Ah, this is what all binary searches do. + else { + if KEY >> firstpart + then bottom := loc + else top := loc + } + } + } + else top := loc # Too far, move back + } +end + +# Perform sequential search of intext for all instances of KEY. + +procedure sequential_search(KEY, intext) #: brute-force database search + + local line, value, off_set + + # Collect all text upto the next colon+colon line (::) + # or EOF. + + off_set := where(intext) + while (line := read(intext)) | fail do { + line ? { + if =("::" || KEY) & (match(" " | "\t") | pos(0)) + then break + else off_set := where(intext) + } + } + value := "" + while line := read(intext) do { + find("::", line) & break + value ||:= line || "\n" + } + + # Debug information for sequential searching: + value := value[1:-1] || " (" || off_set || "-s)\n" + + # Back up to allow for consecutive instances of KEY. + seek(intext, where(intext) - *line - 2) + suspend trim(value || "\n") +end diff --git a/ipl/procs/gobject.icn b/ipl/procs/gobject.icn new file mode 100644 index 0000000..e4ebf70 --- /dev/null +++ b/ipl/procs/gobject.icn @@ -0,0 +1,27 @@ +############################################################################ +# +# File: gobject.icn +# +# Subject: Declarations for geometrical objects +# +# Author: Ralph E. Griswold +# +# Date: July 22, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These declarations are provided for representing geometrical objects +# as records. +# +############################################################################ + +record Circle(center, radius) # point, length +record Line(p1, p2) # point, point +record Point(x, y, z) # x and y coordinates +record Point_Polar(r, a) # radius, angle +record Polygon(points) # list of points +record Rectangle(upper_left, lower_right) # point, point diff --git a/ipl/procs/graphpak.icn b/ipl/procs/graphpak.icn new file mode 100644 index 0000000..7c62ec3 --- /dev/null +++ b/ipl/procs/graphpak.icn @@ -0,0 +1,111 @@ +############################################################################ +# +# File: graphpak.icn +# +# Subject: Procedures for manipulating directed graphs +# +# Author: Ralph E. Griswold +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# The procedures here use sets to represent directed graphs. See +# The Icon Programming Language, second edition, pp. 195-198. +# +# A value of type "graph" has two components: a list of nodes and +# a two-way lookup table. The nodes in turn contain pointers to +# other nodes. The two-way table maps a node to its name and +# vice-versa. +# +# Graph specifications are give in files in which the first line +# is a white-space separated list of node names and subsequent lines +# give the arcs, as in +# +# Tucson Phoenix Bisbee Douglas Flagstaff +# Tucson->Phoenix +# Tucson->Bisbee +# Bisbee->Bisbee +# Bisbee->Douglas +# Douglas->Phoenix +# Douglas->Tucson +# +############################################################################ + +record graph(nodes, lookup) + +# Construct a graph from the specification given in file f. Error checking +# is minimal. + +procedure read_graph(f) #: read graph + local node, nodes, node_list, lookup, arc, from_name, to_name + + nodes := [] # list of the graph nodes + lookup := table() # two-way table of names and nodes + + node_list := read(f) | stop("*** empty specification file") + + node_list ? { # process list of node names + while name := tab(upto('\t ') | 0) do { + node := set() # create a new node + put(nodes, node) # add node to the list + lookup[name] := node # name to node + lookup[node] := name # node to name + tab(many(' \t')) | break + } + } + + while arc := read(f) do { # process arcs + arc ? { + from_name := tab(find("->")) | stop("*** bad arc specification") + move(2) + to_name := tab(0) + insert(\lookup[from_name], \lookup[to_name]) | + stop("*** non-existent node") + } + } + + + return graph(nodes, lookup) # now put the pieces together + +end + +# Write graph g to file f. + +procedure write_graph(g, f) #: write graph + local name_list, node + + name_list := "" # initialize + + every node := !g.nodes do # construct the list of names + name_list ||:= g.lookup[node] || " " + + write(f, name_list[1:-1]) + + every node := !g.nodes do # write the arc specifications + every write(f, g.lookup[node], "->", g.lookup[!node]) + + return + +end + +# Transitive closure of node. Called as closure(node) without second argument + +procedure closure(node, close) #: transitive closure of graph + local n + + /close := set() # initialize closure + + insert(close, node) # add the node itself + + every n := !node do # process all the arcs + # if not member, recurse + member(close, n) | closure(n, close) + + return close + +end diff --git a/ipl/procs/hetero.icn b/ipl/procs/hetero.icn new file mode 100644 index 0000000..85a6609 --- /dev/null +++ b/ipl/procs/hetero.icn @@ -0,0 +1,48 @@ +############################################################################ +# +# File: hetero.icn +# +# Subject: Procedures to test structure typing +# +# Author: Ralph E. Griswold +# +# Date: April 19, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# +# +############################################################################ + +procedure stypes(X, ref) #: types of structure elements + local op, types, t, k + + op := proc("!", 1) + t := type(X) + op := if (t == "table") & (ref === 1) then "key" + + if (t == "table") & (ref === 2) then { + types := set() + every k := key(X) do + insert(types, type(k) || ":" || type(X[k])) + return sort(types) + } + + else if t == ("list" | "record" | "table" | "set") then { + types := set() + every insert(types, type(op(X))) + return sort(types) + } + else stop("*** invalid type to stypes()") + +end + +procedure homogeneous(X, ref) + + if *stypes(X, ref) = 1 then return else fail + +end diff --git a/ipl/procs/hexcvt.icn b/ipl/procs/hexcvt.icn new file mode 100644 index 0000000..4da5e31 --- /dev/null +++ b/ipl/procs/hexcvt.icn @@ -0,0 +1,54 @@ +############################################################################ +# +# File: hexcvt.icn +# +# Subject: Procedures for hexadecimal conversion +# +# Author: Robert J. Alexander +# +# Date: June 7, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# hex(s) -- Converts string of hex digits into an integer. +# +# hexstring(i,n,lc) -- Returns a string that is the hexadecimal +# representation of the argument. If n is supplied, a minimum +# of n digits appear in the result; otherwise there is no minimum, +# and negative values are indicated by a minus sign. If lc is +# non-null, lowercase characters are used instead of uppercase. +# +############################################################################ + +procedure hex(s) + local a,c + a := 0 + every c := !map(s) do + a := ior(find(c,"0123456789abcdef") - 1,ishift(a,4)) | fail + return a +end + +procedure hexstring(i,n,lowercase) + local s,hexchars,sign + i := integer(i) | runerr(101,i) + sign := "" + if i = 0 then s := "0" + else { + if /n & i < 0 then { + sign := "-" + i := -i + } + hexchars := if \lowercase then "0123456789abcdef" else "0123456789ABCDEF" + s := "" + until i = (0 | -1) do { + s := hexchars[iand(i,15) + 1] || s + i := ishift(i,-4) + } + } + if \n > *s then s := right(s,n,if i >= 0 then "0" else hexchars[16]) + return sign || s +end diff --git a/ipl/procs/hostname.icn b/ipl/procs/hostname.icn new file mode 100644 index 0000000..c25be4d --- /dev/null +++ b/ipl/procs/hostname.icn @@ -0,0 +1,54 @@ +############################################################################ +# +# File: hostname.icn +# +# Subject: Procedures to produce host name +# +# Author: Richard L. Goerwitz +# +# Date: April 30, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.1 +# +############################################################################ +# +# This procedure determines the name of the current host. It takes no +# arguments. Aborts with an error message if the necessary commands +# are not found. Geared specifically for UNIX machines. +# +############################################################################ +# +# Requires: UNIX, pipes +# +############################################################################ + +procedure hostname() + local fname, get_name + + static h_name + initial { + (find("UNIX",&features), find("pipes",&features)) | + stop("hostname: works only under UNIX") + close(open(fname <- "/usr/bin/hostname"|"/bin/uuname"|"/bin/uname")) + fname := { + case \fname of { + "/usr/bin/hostname" : "/usr/bin/hostname" + "/usr/bin/uuname" : "/usr/bin/uuname -l" + "/bin/uname" : "/bin/uname -n" + } | "/usr/bin/uuname -l" + } + get_name := open(fname, "pr") | + stop("hostname: can't find hostname/uuname/uname commands") + h_name := !get_name + close(get_name) + } + + return h_name + +end diff --git a/ipl/procs/html.icn b/ipl/procs/html.icn new file mode 100644 index 0000000..50f7086 --- /dev/null +++ b/ipl/procs/html.icn @@ -0,0 +1,334 @@ +############################################################################ +# +# File: html.icn +# +# Subject: Procedures for parsing HTML +# +# Author: Gregg M. Townsend +# +# Date: April 26, 2005 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures parse HTML files: +# +# htchunks(f) generates the basic chunks -- tags and text -- +# that compose an HTML file. +# +# htrefs(f) generates the tagname/keyword/value combinations +# that reference other files. +# +# These procedures process strings from HTML files: +# +# httag(s) extracts the name of a tag. +# +# htvals(s) generates the keyword/value pairs from a tag. +# +# urlmerge(base,new) interprets a new URL in the context of a base. +# +# canpath(s) puts a path in canonical form +# +############################################################################ +# +# htchunks(f) generates the HTML chunks from file f. +# It returns strings beginning with +# +# <!-- for unclosed comments (legal comments are deleted) +# < for tags (will end with ">" unless unclosed at EOF) +# anything else for text +# +# At this level entities such as & are left unprocessed and all +# whitespace is preserved, including newlines. +# +############################################################################ +# +# htrefs(f) extracts file/url references from within an HTML file +# and generates a string of the form +# tagname keyword value +# for each reference. +# +# A single space character separates the three fields, but if no +# value is supplied for the keyword, no space follows the keyword. +# Tag and keyword names are always returned in upper case. +# +# Quotation marks are stripped from the value, but note that the +# value can contain spaces or other special characters (although +# by strict HTML rules it probably shouldn't). +# +# A table in the code determines which fields are references to +# other files. For example, with <IMG>, SRC= is a reference but +# WIDTH= is not. The table is based on the HTML 4.0 standard: +# http://www.w3.org/TR/REC-html40/ +# +############################################################################ +# +# httag(s) extracts and returns the tag name from within an HTML +# tag string of the form "<tagname...>". The tag name is returned +# in upper case. +# +############################################################################ +# +# htvals(s) generates the tag values contained within an HTML tag +# string of the form "<tagname kw=val kw=val ...>". For each +# keyword=value pair beyond the tagname, a string of the form +# +# keyword value +# +# is generated. One space follows the keyword, which is returned +# in upper case, and quotation marks are stripped from the value. +# The value itself can be an empty string. +# +# For each keyword given without a value, the keyword is generated +# in upper case with no following space. +# +# Parsing is somewhat tolerant of errors. +# +############################################################################ +# +# urlmerge(base,new) interprets a full or partial new URL in the +# context of a base URL, returning the combined URL. +# +# Here are some examples of applying urlmerge() with a base value +# of "http://www.vcu.edu/misc/sched.html" and a new value as given: +# +# new result +# ------------- ------------------- +# #tuesday http://www.vcu.edu/misc/sched.html#tuesday +# bulletin.html http://www.vcu.edu/misc/bulletin.html +# ./results.html http://www.vcu.edu/misc/results.html +# images/rs.gif http://www.vcu.edu/misc/images/rs.gif +# ../ http://www.vcu.edu/ +# /greet.html http://www.vcu.edu/greet.html +# file:a.html file:a.html +# +############################################################################ +# +# canpath(s) returns the canonical form of a file path by squeezing +# out components such as "./" and "dir/../". +# +############################################################################ + + +# htchunks(f) -- generate HTML chunks from file f + +procedure htchunks(f) #: generate chunks of HTML file + local prev, line, s + + "" ? repeat { + + if pos(0) then + &subject := (read(f) || "\n") | fail + + if ="<!--" then + suspend htc_comment(f) # fails if comment is legal + else if ="<" then + suspend htc_tag(f) # generate tag + else + suspend htc_text(f) # generate text chunk + + } +end + +procedure htc_tag(f) + local s + + s := "<" + repeat { + if s ||:= tab(upto('>') + 1) then + return s # completed tag + s ||:= tab(0) + &subject := (read(f) || "\n") | break + } + return s # unclosed tag +end + +procedure htc_comment(f) + local s + + s := "" + repeat { + if s ||:= tab(find("-->") + 3) then + fail # normal case: discard comment + s ||:= tab(0) + &subject := (read(f) || "\n") | break + } + + &subject := s # rescan unclosed comment + return "<!--" # return error indicator +end + +procedure htc_text(f) + local s + + s := "" + repeat { + if s ||:= tab(upto('<')) then + return s + s ||:= tab(0) + &subject := (read(f) || "\n") | return s + } +end + + +## htrefs(f) -- generate references from HTML file f + +procedure htrefs(f) #: generate references from HTML file + local tag, tagname, kwset, s + static ttable + initial { + ttable := table() + ttable["A"] := set(["HREF"]) + ttable["APPLET"] := set(["CODEBASE"]) + ttable["AREA"] := set(["HREF"]) + ttable["BASE"] := set(["HREF"]) + ttable["BLOCKQUOTE"] := set(["CITE"]) + ttable["BODY"] := set(["BACKGROUND"]) + ttable["DEL"] := set(["CITE"]) + ttable["FORM"] := set(["ACTION"]) + ttable["FRAME"] := set(["SRC", "LONGDESC"]) + ttable["HEAD"] := set(["PROFILE"]) + ttable["IFRAME"] := set(["SRC", "LONGDESC"]) + ttable["IMG"] := set(["SRC", "LONGDESC", "USEMAP"]) + ttable["INPUT"] := set(["SRC", "USEMAP"]) + ttable["INS"] := set(["CITE"]) + ttable["LINK"] := set(["HREF"]) + ttable["OBJECT"] := set(["CLASSID","CODEBASE","DATA","ARCHIVE","USEMAP"]) + ttable["Q"] := set(["CITE"]) + ttable["SCRIPT"] := set(["SRC", "FOR"]) + } + + every tag := htchunks(f) do { + tagname := httag(tag) | next + kwset := \ttable[tagname] | next + every s := htvals(tag) do + if member(kwset, s ? tab(upto(' '))) then + suspend tagname || " " || s + } +end + + + +## httag(s) -- return the name of the HTML tag s + +procedure httag(s) #: extract name of HTML tag + static idset, wset, lcase, ucase + initial { + idset := &letters ++ &digits ++ '.-/' + wset := ' \t\r\n\v\f' + lcase := string(&lcase) + ucase := string(&ucase) + } + + s ? { + ="<" | fail + tab(many(wset)) + return map(tab(many(idset)), lcase, ucase) + } +end + + + +## htvals(s) -- generate tag values of HTML tag s + +procedure htvals(s) #: generate values in HTML tag + local kw + static idset, wset, qset, lcase, ucase + initial { + idset := &letters ++ &digits ++ '.-/' + wset := ' \t\r\n\v\f' + qset := wset ++ '>' + lcase := string(&lcase) + ucase := string(&ucase) + } + + s ? { + ="<" | fail + tab(many(wset)) + tab(many(idset)) | fail # no name + repeat { + tab(upto(idset)) | fail + kw := map(tab(many(idset)), lcase, ucase) + tab(many(wset)) + if ="=" then { + tab(many(wset)) + kw ||:= " " + if ="\"" then { + kw ||:= tab(upto('"') | 0) + tab(any('"')) + } + else if ="'" then { + kw ||:= tab(upto('\'') | 0) + tab(any('\'')) + } + else + kw ||:= tab(upto(qset) | 0) + } + suspend kw + } + } +end + + + +# urlmerge(base,new) -- merge URLs + +procedure urlmerge(base, new) #: merge URLs + local protocol, host, path + static notslash + initial notslash := ~'/' + + if new ? (tab(many(&letters)) & =":") then + return new # new is fully specified + + base ? { + protocol := (tab(many(&letters)) || =":") | "" + host := (="//" || tab(upto('/') | 0)) | "" + path := tab(upto('#') | 0) + } + + new ? { + if ="#" then + return protocol || host || path || new + if ="/" then + return protocol || host || new + } + + path := trim(path, notslash) || new + + return protocol || host || canpath(path) +end + + + +# canpath(path) -- return canonical version of path +# +# This is similar to step 6 of section 4 of RFC 1808. + +procedure canpath(path) #: put path in canonical form + static notslash + initial notslash := ~'/' + + # change "/./" to "/" + while path ?:= 1(tab(find("/./")), move(2)) || tab(0) + + # change "//" to "/" + while path ?:= tab(find("//") + 1) || (tab(many('/')) & tab(0)) + + # remove "dir/../" + while path ?:= + (tab(1 | (upto('/') + 1))) || + ((tab(many(notslash)) ~== "..") & ="/../" & tab(0)) + + # remove leading "./" + while path ?:= (="./" & tab(0)) + + # remove trailing "." + path ?:= if tab(-2) & ="/." then path[1:-1] + path ?:= if ="." & pos(0) then "" + + return path +end diff --git a/ipl/procs/ibench.icn b/ipl/procs/ibench.icn new file mode 100644 index 0000000..ae47370 --- /dev/null +++ b/ipl/procs/ibench.icn @@ -0,0 +1,171 @@ +############################################################################ +# +# File: ibench.icn +# +# Subject: Procedures to support Icon benchmarking +# +# Author: Ralph E. Griswold +# +# Date: March 23, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Procedures to support benchmarking of Icon programs: +# +# Init__(prog) initialize for benchmarking +# Term__() terminate benchmarking +# Allocated__() get amounts allocated +# Collections__() get collections +# Regions__() get regions +# Signature__() show program/environment information +# Storage__() get storage +# Time__() show elapsed time +# Display__(data,name) show information +# +############################################################################ +# +# The code to be timed is bracketed by calls to Init__(name) +# and Term__(), where name is used for tagging the results. +# The typical usage is: +# +# procedure main() +# [declarations] +# Init__(name) +# . +# . +# . +# Term__() +# end +# +# If the environment variable OUTPUT is set, program output is +# not suppressed. +# +# If the environment variable NOBENCH is set, benchmarking is not +# performed (and OUTPUT has no effect). This allows a program that +# links ibench to run in the ordinary way. +# +############################################################################ + +global Save__, Saves__, Name__, Labels__ + +# List information before running. +# +procedure Init__(prog) + if getenv("NOBENCH") then { # don't do benchmarking + Term__ := 1 + return + } + Name__ := prog # program name + Labels__ := ["total ","static","string","block "] + write(Name__,": benchmarking\n") + Signature__() # initial information + Regions__() + Time__() + if not getenv("OUTPUT") then { # if OUTPUT is set, allow output + Save__ := write # turn off output + Saves__ := writes + write := writes := -1 + } + else write(Name__,": output\n") + return +end + +# List information at termination. + +procedure Term__() + if not getenv("OUTPUT") then { # if OUTPUT is not set, restore output + write := Save__ + writes := Saves__ + } + # final information + Regions__() + Storage__() + Collections__() + Allocated__() + write("\n",Name__,": elapsed time = ",Time__()," ms.") + return +end + +# +# List total amounts of allocation. Needs Icon Version 8.5 or above. +# +procedure Allocated__() + local allocated + + allocated := [] + every put(allocated,&allocated) + Display__(allocated,"allocated") + return + +end + +# List garbage collections performed. +# +procedure Collections__() + local collections + + collections := [] + every put(collections,&collections) + Display__(collections,"collections") + return +end + +# List region sizes. +# +procedure Regions__() + local regions, count + + regions := [] + every put(regions,®ions) + count := 0 + every count +:= !regions + push(regions,count) + Display__(regions,"regions") + return +end + +# List relveant implementation information +# +procedure Signature__() + + every write(&version | &host | &features) + return + +end + +# List storage used. +# +procedure Storage__() + local storage, count + + storage := [] + every put(storage,&storage) + count := 0 + every count +:= !storage + push(storage,count) + Display__(storage,"storage") + return +end + +# List elapsed time. +# +procedure Time__() + static lasttime + + initial lasttime := &time + return &time - lasttime +end + +# Display storage information +# +procedure Display__(data,name) + local i + + write("\n",name,":\n") + every i := 1 to *Labels__ do + write(Labels__[i],right(data[i],8)) +end diff --git a/ipl/procs/ichartp.icn b/ipl/procs/ichartp.icn new file mode 100644 index 0000000..b5968bd --- /dev/null +++ b/ipl/procs/ichartp.icn @@ -0,0 +1,611 @@ +############################################################################ +# +# File: ichartp.icn +# +# Subject: Procedures for a simple chart parser +# +# Author: Richard L. Goerwitz +# +# Date: August 3, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.11 +# +############################################################################ +# +# General: +# +# Ichartp implements a simple chart parser - a slow but +# easy-to-implement strategy for parsing context free grammars (it +# has a cubic worst-case time factor). Chart parsers are flexible +# enough to handle a lot of natural language constructs. They also +# lack many of the troubles associated with empty and left-recursive +# derivations. To obtain a parse, just create a BNF file, obtain a +# line of input, and then invoke parse_sentence(sentence, +# bnf_filename, start-symbol). Parse_sentence suspends successive +# edge structures corresponding to possible parses of the input +# sentence. There is a routine called edge_2_tree() that converts +# these edges to a more standard form. See the stub main() procedure +# for an example of how to make use of all these facilities. +# +############################################################################ +# +# Implementation details: +# +# The parser itself operates in bottom-up fashion, but it might +# just as well have been coded top-down, or for that matter as a +# combination bottom-up/top-down parser (chart parsers don't care). +# The parser operates in breadth-first fashion, rather than walking +# through each alternative until it is exhausted. As a result, there +# tends to be a pregnant pause before any results appear, but when +# they appear they come out in rapid succession. To use a depth-first +# strategy, just change the "put" in "put(ch.active, new_e)" to read +# "push." I haven't tried to do this, but it should be that simple +# to implement. +# BNFs are specified using the same notation used in Griswold & +# Griswold, and as described in the IPL program "pargen.icn," with +# the following difference: All metacharacters (space, tab, vertical +# slash, right/left parends, brackets and angle brackets) are +# converted to literals by prepending a backslash. Comments can be +# include along with BNFs using the same notation as for Icon code +# (i.e. #-sign). +# +############################################################################ +# +# Gotchas: +# +# Pitfalls to be aware of include things like <L> ::= <L> | ha | +# () (a weak attempt at a laugh recognizer). This grammar will +# accept "ha," "ha ha," etc. but will suspend an infinite number of +# possible parses. The right way to do this sort of thing is <L> ::= +# ha <S> | ha, or if you really insist on having the empty string as +# a possibility, try things like: +# +# <S> ::= () | <LAUGHS> +# <LAUGHS> ::= ha <LAUGHS> | ha +# +# Of course, the whole problem of infinite parses can be avoided by +# simply invoking the parser in a context where it is not going to +# be resumed, or else one in which it will be resumed a finite number +# of times. +# +############################################################################ +# +# Motivation: +# +# I was reading Byte Magazine (vol. 17:2 [February, 1992]), and +# ran into an article entitled "A Natural Solution" (pages 237-244) +# in which a standard chart parser was described in terms of its C++ +# implementation. The author remarked at how his optimizations made +# it possible to parse a 14-word sentence in only 32 seconds (versus +# 146 for a straight Gazdar-Mellish LISP chart parser). 32 seconds +# struck me as hardly anything to write home about, so I coded up a +# quick system in Icon to see how it compared. This library is the +# result. +# I'm quite sure that this code could be very much improved upon. +# As it stands, its performance seems as good as the C++ parser in +# BYTE, if not better. It's hard to tell, though, seeing as I have +# no idea what hardware the guy was using. I'd guess a 386 running +# DOS. On a 386 running Xenix the Icon version beats the BYTE times +# by a factor of about four. The Icon compiler creates an executable +# that (in the above environment) parses 14-15 word sentences in +# anywhere from 6 to 8 seconds. Once the BNF file is read, it does +# short sentences in a second or two. If I get around to writing it, +# I'll probably use the code here as the basic parsing engine for an +# adventure game my son wants me to write. +# +############################################################################ +# +# Links: trees, rewrap, scan, strip, stripcom, strings +# +############################################################################ +# +# Requires: co-expressions +# +############################################################################ +# +# Here's a sample BNF file (taken, modified, from the BYTE +# Magazine article mentioned above). Note again the conventions a) +# that nonterminals be enclosed in angle brackets & b) that overlong +# lines be continued by terminating the preceding line with a +# backslash. Although not illustrated below, the metacharacters <, +# >, (, ), and | can all be escaped (i.e. can all have their special +# meaning neutralized) with a backslash (e.g. \<). Comments can also +# be included using the Icon #-notation. Empty symbols are illegal, +# so if you want to specify a zero-derivation, use "()." There is an +# example of this usage below. +# +# <S> ::= <NP> <VP> | <S> <CONJ> <S> +# <VP> ::= <VP> <CONJ> <VP> | <IV> ( () | <PP> ) | \ +# <TV> ( <NP> | <NP> <PP> | <NP> <VP> | <REL> <S> ) +# <NP> ::= <DET> ( <NP> | <ADJ> <NP> | <ADJ> <NP> <PP> | <NP> <PP> ) | \ +# <ADJ> <NP> | <N> | <N> <CONJ> <N> | \ +# <NP> <CONJ> <NP> +# <PP> ::= <P> ( <NP> | <ADJ> <NP> ) | <PP> <CONJ> <PP> +# <ADJ> ::= <ADJ> <CONJ> <ADJ> +# <CONJ> ::= and +# <DET> ::= the | a | his | her +# <NP> ::= her | he | they +# <N> ::= nurse | nurses | book | books | travel | arrow | arrows | \ +# fortune | fortunes | report +# <ADJ> ::= outrageous | silly | blue | green | heavy | white | red | \ +# black | yellow +# <IV> ::= travel | travels | report | see | suffer +# <TV> ::= hear | see | suffer +# <P> ::= on | of +# <REL> ::= that +# +############################################################################ +# +# Addendum: +# +# Sometimes, when writing BNFs, one finds oneself repeatedly +# writing the same things. In efforts to help eliminate the need for +# doing this, I've written a simple macro facility. It involves one +# reserved word: "define." Just make sure it begins a line. It +# takes two arguments. The first is the macro. The second is its +# expansion. The first argument must not contain any spaces. The +# second, however, may. Here's an example: +# +# define <silluq-clause> ( <silluq-phrase> | \ +# <tifcha-silluq-clause> | \ +# <zaqef-silluq-clause> \ +# ) +# +############################################################################ + +link trees +link scan +link rewrap +link strip +link stripcom +link strings + +record stats(edge_list, lhs_table, term_set) +record chart(inactive, active) # inactive - set; active - list +record retval(no, item) + +record edge(LHS, RHS, LEN, DONE, BEG, END, SEEN) +record short_edge(LHS, RHS) + +# +# For debugging only. +# +procedure main(a) + + local res, filename, line + # &trace := -1 + filename := \a[1] | "bnfs.byte" + while line := read(&input) do { + res := &null + every res := parse_sentence(line, filename, "S") do { + if res.no = 0 then + write(stree(edge2tree(res.item))) +# write(ximage(res.item)) + else if res.no = 1 then { + write("hmmm") + write(stree(edge2tree(res.item))) + } + } + /res & write("can't parse ",line) + } + +end + + +# +# parse_sentence: string x string -> edge records +# (s, filename) -> Es +# where s is a chunk of text presumed to constitute a sentence +# where filename is the name of a grammar file containing BNFs +# where Es are edge records containing possible parses of s +# +procedure parse_sentence(s, filename, start_symbol) + + local file, e, i, elist, ltbl, tset, ch, tokens, st, + memb, new_e, token_set, none_found, active_modified + static master, old_filename + initial master := table() + + # + # Initialize and store stats for filename (if not already stored). + # + if not (filename == \old_filename) then { + file := open(filename, "r") | p_err(filename, 7) + # + # Read BNFs from file; turn them into edge structs, and + # store them all in a list; insert terminal symbols into a set. + # + elist := list(); ltbl := table(); tset := set() + every e := bnf_file_2_edges(file) do { + put(elist, e) # main edge list (active) + (/ltbl[e.LHS] := set([e])) | insert(ltbl[e.LHS], e) # index LHSs + every i := 1 to e.LEN do # LEN holds length of e.RHS + if /e.RHS[i].RHS then # RHS for terminals is null + insert(tset, e.RHS[i].LHS) + } + insert(master, filename, stats(elist, ltbl, tset)) + old_filename := filename + close(file) + } + elist := fullcopy(master[filename].edge_list) + ltbl := fullcopy(master[filename].lhs_table) + tset := master[filename].term_set + + # + # Make edge list into the active section of chart; tokenize the + # sentence s & check for unrecognized terminals. + # + ch := chart(set(), elist) + tokens := tokenize(s) + + # + # Begin parse by entering all tokens in s into the inactive set + # in the chart as edges with no RHS (a NULL RHS is characteristic + # of all terminals). + # + token_set := set(tokens) + every i := 1 to *tokens do { + # Flag words not in the grammar as errors. + if not member(tset, tokens[i]) then + suspend retval(1, tokens[i]) + # Now, give us an inactive edge corresponding to word i. + insert(ch.inactive, e := edge(tokens[i], &null, 1, 1, i, i+1)) + # Insert word i into the LHS table. + (/ltbl[tokens[i]] := set([e])) | insert(ltbl[tokens[i]], e) + # Watch out for those empty RHSs. + insert(ch.inactive, e := edge("", &null, 1, 1, i, i)) + (/ltbl[""] := set([e])) | insert(ltbl[""], e) + } + *tokens = 0 & i := 0 + insert(ch.inactive, e := edge("", &null, 1, 1, i+1, i+1)) + (/ltbl[""] := set([e])) | insert(ltbl[""], e) + + # + # Until no new active edges can be built, keep ploughing through + # the active edge list, trying to match unconfirmed members of their + # RHSs up with inactive edges. + # + until \none_found do { +# write(ximage(ch)) + none_found := 1 + every e := !ch.active do { + active_modified := &null + # keep track of inactive edges we've already tried + /e.SEEN := set() + # + # e.RHS[e.DONE+1] is the first unconfirmed category in the + # RHS of e; ltbl[e.RHS[e.DONE+1].LHS] are all edges having + # as their LHS the LHS of the first unconfirmed category in + # e's RHS; we simply intersect this set with the inactives, + # and then subtract out those we've seen before in connec- + # tion with this edge - + # + if *(st := \ltbl[e.RHS[e.DONE+1].LHS] ** ch.inactive -- e.SEEN) > 0 + then { + # record all the inactive edges being looked at as seen + e.SEEN ++:= st + every memb := !st do { + # make sure this inactive edge starts where the + # last confirmed edge in e.RHS ends! + if memb.BEG ~= \e.RHS[e.DONE].END then next + # set none_found to indicate we've created a new edge + else none_found := &null + # create a new edge, having the LHS of e, the RHS of e, + # the start point of e, the end point of st, and one more + # confirmed RHS members than e + new_e := edge(e.LHS, fullcopy(e.RHS), + e.LEN, e.DONE+1, e.BEG, memb.END) + new_e.RHS[new_e.DONE] := memb + /new_e.BEG := memb.BEG + if new_e.LEN = new_e.DONE then { # it's inactive + insert(ch.inactive, new_e) + insert(ltbl[e.LHS], new_e) + if new_e.BEG = 1 & new_e.END = (*tokens+1) then { + if new_e.LHS == start_symbol # complete parse + then suspend retval(0, new_e) + } + } else { + put(ch.active, new_e) # it's active + active_modified := 1 + } + } + } + # restart if the ch.active list has been modified + if \active_modified then break next + } + } + +end + + +# +# tokenize: break up a sentence into constituent words, using spaces, +# tabs, and other punctuation as separators (we'll need to +# change this a bit later on to cover apostrophed words) +# +procedure tokenize(s) + + local l, word + + l := list() + s ? { + while tab(upto(&letters)) do + put(l, map(tab(many(&letters)))) + } + return l + +end + + +# +# edge2tree: edge -> tree +# e -> t +# +# where e is an edge structure (active or inactive; both are okay) +# where t is a tree like what's described in Ralph Griswold's +# structs library (IPL); I don't know about the 2nd ed. of +# Griswold & Griswold, but the structure is described in the 1st +# ed. in section 16.1 +# +# fails if, for some reason, the conversion can't be made (e.g. the +# edge structure has been screwed around with in some way) +# +procedure edge2tree(e) + + local memb, t + + t := [e.LHS] + \e.RHS | (return t) # a terminal + type(e) == "edge" | (return put(t, [])) # An incomplete edge + every memb := !e.RHS do # has daughters. + put(t, edge2tree(memb)) + return t + +end + + +# +# bnf_file_2_edges: concatenate backslash-final lines & parse +# +procedure bnf_file_2_edges(f) + + local getline, line, macro_list, old, new, i + + macro_list := list() + getline := create stripcom(!f) + while line := @getline do { + while line ?:= 1(tab(-2) || tab(slshupto('\\')), pos(-1)) || @getline + line ? { + if ="define" then { + tab(many('\t ')) + old := tab(slshupto('\t ')) | + stop("bnf_file_2_edges", 7, tab(0)) + tab(many('\t ')) + new := tab(0) + (!macro_list)[1] == old & + stop("bnf_file_2_edges", 8, old) + put(macro_list, [old, new]) + next # go back to main loop + } + else { + every i := 1 to *macro_list do + # Replace is in the IPL (strings.icn). + line := replace(line, macro_list[i][1], macro_list[i][2]) + suspend bnf_2_edges(line) + } + } + } + +end + + +# +# bnf_2_edges: string -> edge records +# s -> Es (a generator) +# where s is a CFPSG rule in BNF form +# where Es are edges +# +procedure bnf_2_edges(s) + + local tmp, RHS, LHS + # + # Break BNF-style CFPSG rule into LHS and RHS. If there is more + # than one RHS (a la the | alternation op), suspend multiple re- + # sults. + # + s ? { + # tab upto the ::= sign + tmp := (tab(slshupto(':')) || ="::=") | p_err(s, 1) + # strip non-backslashed spaces, and extract LHS symbol + stripspaces(tmp) ? { + LHS := 1(tab(slashbal(':', '<', '>')), ="::=") | p_err(s, 1) + LHS ?:= strip(2(="<", tab(-1), =">"), '\\') | p_err(s, 2) + LHS == "" & p_err(s, 6) + } + every RHS := do_slash(tab(0) \ 1) do { + RHS := string_2_list(RHS) + suspend edge(LHS, RHS, *RHS, 0, &null, &null) + } + } + +end + + +# +# string_2_list: string -> list +# s -> L +# where L is a list of partially constructed (short) edges, having +# only LHS and RHS; in the case of nonterminals, the RHS is set +# to 1, while for terminals the RHS is null (and remains that way +# throughout the parse) +# +procedure string_2_list(s) + + local tmp, RHS_list, LHS + + (s || "\x00") ? { + tab(many(' \t')) + pos(-1) & (return [short_edge("", &null)]) + RHS_list := list() + repeat { + tab(many(' \t')) + pos(-1) & break + if match("<") then { + tmp := ("" ~== tab(slashbal(&cset, '<', '>'))) | p_err(s, 4) + LHS := stripspaces(tmp) + LHS ?:= strip(2(="<", tab(-1), =">"), '\\') | p_err(s, 4) + LHS == "" & p_err(s, 10) + put(RHS_list, short_edge(LHS, 1)) + } else { + LHS := stripspaces(tab(slshupto(' <') | -1)) + slshupto('>', LHS) & p_err(s, 5) + put(RHS_list, short_edge(strip(LHS, '\\'), &null)) + } + } + } + return RHS_list + +end + + +# +# fullcopy: make full recursive copy of object +# +procedure fullcopy(obj) + + local retval, i, k + + case type(obj) of { + "co-expression" : return obj + "cset" : return obj + "file" : return obj + "integer" : return obj + "list" : { + retval := list(*obj) + every i := 1 to *obj do + retval[i] := fullcopy(obj[i]) + return retval + } + "null" : return &null + "procedure" : return obj + "real" : return obj + "set" : { + retval := set() + every insert(retval, fullcopy(!obj)) + return retval + } + "string" : return obj + "table" : { + retval := table(obj[[]]) + every k := key(obj) do + insert(retval, fullcopy(k), fullcopy(obj[k])) + return retval + } + # probably a record; if not, we're dealing with a new + # version of Icon or a nonstandard implementation, and + # we're screwed + default : { + retval := copy(obj) + every i := 1 to *obj do + retval[i] := fullcopy(obj[i]) + return retval + } + } + +end + + +# +# do_slash: string -> string(s) +# Given a|b suspend a then b. Used in conjunction with do_parends(). +# +procedure do_slash(s) + + local chunk + s ? { + while chunk := tab(slashbal('|', '(', ')')) do { + suspend do_parends(chunk) + move(1) + } + suspend do_parends(tab(0)) + } + +end + + +# +# do_parends: string -> string(s) +# Given a(b)c suspend abc; given a(b|c)d suspend abd and acd, etc. +# Used in conjuction with do_slash(). +# +procedure do_parends(s) + + local chunk, i, j + s ? { + if not (i := slshupto('(')) then { + chunk := tab(0) + slshupto(')') & p_err(s, 8) + suspend chunk + } else { + j := i + slashbal(')', '(', ')', s[i+1:0]) | p_err(s, 9) + suspend tab(i) || + (move(1), do_slash(tab(j))) || + (move(1), do_parends(tab(0))) + } + } + +end + + +# +# p_err: print error message to stderr & abort +# +procedure p_err(s, n) + + local i, msg + static errlist + initial { + errlist := [[1, "malformed LHS"], + [2, "nonterminal lacks proper <> enclosure"], + [3, "missing left angle bracket"], + [4, "unmatched left angle bracket"], + [5, "unmatched right angle bracket"], + [6, "empty symbol in LHS"], + [7, "unable to open file"], + [8, "unmatched right parenthesis"], + [9, "unmatched left parenthesis"], + [10, "empty symbol in RHS"] + ] + } + every i := 1 to *errlist do + if errlist[i][1] = n then msg := errlist[i][2] + writes(&errout, "error ", n, " (", msg, ") in \n") + every write("\t", rewrap(s) | rewrap()) + exit(n) + +end + + +# +# Remove non-backslashed spaces and tabs. +# +procedure stripspaces(s) + + local s2 + + s2 := "" + s ? { + while s2 ||:= tab(slshupto(' \t')) do + tab(many(' \t')) + s2 ||:= tab(0) + } + + return s2 + +end diff --git a/ipl/procs/identgen.icn b/ipl/procs/identgen.icn new file mode 100644 index 0000000..bb40b71 --- /dev/null +++ b/ipl/procs/identgen.icn @@ -0,0 +1,479 @@ +############################################################################ +# +# File: identgen.icn +# +# Subject: Procedures for meta-translation code generation +# +# Author: Ralph E. Griswold +# +# Date: August 3, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program is designed to be linked with the output of the meta- +# translator. As given here, they produce an identity translation. +# Modifications can be made to effect different translations. +# +############################################################################ +# +# Bug: The invocable declaration is not handled properly. "invocable all" +# will get by, but some other forms produce syntax errors. The +# problem is in the meta-translator itself, not in this program. +# +############################################################################ +# +# Links: strings +# +############################################################################ + +link strings # cat(s1, s2, ... ) + +global code_gen + +procedure main() + + code_gen := cat # so it can be changed easily + + Mp() # call meta-procedure + +end + +procedure Alt(e1, e2) # e1 | e2 + + return code_gen("(", e1, "|", e2, ")") + +end + +procedure Apply(e1, e2) # e1 ! e2 + + return code_gen("(", e1, "!", e2, ")") + +end + +procedure Arg(e) + + return e + +end + +procedure Asgnop(op, e1, e2) # e1 op e2 + + return code_gen("(", e1, " ", op, " ", e2, ")") + +end + +procedure Augscan(e1, e2) # e1 ?:= e2 + + return code_gen("(", e1, " ?:= ", e2, ")") + +end + +procedure Bamper(e1, e2) # e1 & e2 + + return code_gen("(", e1, " & ", e2, ")") + +end + +procedure Binop(op, e1, e2) # e1 op e2 + + return code_gen("(", e1, " ", op, " ", e2, ")") + +end + +procedure Body(es[]) # procedure body + + every write(!es) + + return + +end + +procedure Break(e) # break e + + return code_gen("break ", e) + +end + +procedure Case(e, clist) # case e of { caselist } + + return code_gen("case ", e, " of {", clist, "}") + +end + +procedure Cclause(e1, e2) # e1 : e2 + + return code_gen(e1, " : ", e2, "\n") + +end + +procedure Clist(cclause1, cclause2) # cclause1 ; cclause2 + + return code_gen(cclause1, ";", cclause2) + +end + +procedure Clit(c) # 'c' + + return image(c) + +end + +procedure Compound(es[]) # { e1; e2; ... } + local result + + if *es = 0 then return "{}\n" + + result := "{\n" + every result ||:= !es || "\n" + + return code_gen(result, "}\n") + +end + +procedure Create(e) # create e + + return code_gen("create ", e) + +end + +procedure Default(e) # default: e + + return code_gen("default: ", e) + +end + +procedure End() # end + + write("end") + + return + +end + +procedure Every(e) # every e + + return code_gen("every ", e) + +end + +procedure EveryDo(e1, e2) # every e1 do e2 + + return code_gen("every ", e1, " do ", e2) + +end + +procedure Fail() # fail + + return "fail" + +end + +procedure Field(e, f) # e . f + + return code_gen("(", e, ".", f, ")") + +end + +procedure Global(vs[]) # global v1, v2, ... + local result + + result := "" + every result ||:= !vs || ", " + + write("global ", result[1:-2]) + + return + +end + +procedure If(e1, e2) # if e1 then e2 + + return code_gen("if ", e1, " then ", e2) + +end + +procedure IfElse(e1, e2, e3) # if e1 then e2 else e3 + + return code_gen("if ", e1, " then ", e2, " else ", e3) + +end + +procedure Ilit(i) # i + + return i + +end + +procedure Initial(e) # initial e + + write("initial ", e) + + return + +end + +procedure Invocable(ss[]) # invocable s1, s2, ... (problem) + + if \ss then write("invocable all") + else write("invocable ", ss) + + return + +end + +procedure Invoke(e, es[]) # e(e1, e2, ...) + local result + + if *es = 0 then return code_gen(e, "()") + + result := "" + every result ||:= !es || ", " + + return code_gen(e, "(", result[1:-2], ")") + +end + +procedure Key(s) # &s + + return code_gen("&", s) + +end + +procedure Limit(e1, e2) # e1 \ e2 + + return code_gen("(", e1, "\\", e2, ")") + +end + +procedure Link(vs[]) # link "v1, v2, ..." + local result + + result := "" + every result ||:= !vs || ", " + + write("link ", result[1:-2]) + + return + +end + +procedure List(es[]) # [e1, e2, ... ] + local result + + if *es = 0 then return "[]" + + result := "" + every result ||:= !es || ", " + + return code_gen("[", result[1:-2], "]") + +end + +procedure Local(vs[]) # local v1, v2, ... + local result + + result := "" + every result ||:= !vs || ", " + + write("local ", result[1:-2]) + + return + +end + +procedure Next() # next + + return "next" + +end + +procedure Not(e) # not e + + return code_gen("not(", e, ")") + +end + +procedure Null() # &null + + return "" + +end + +procedure Paren(es[]) # (e1, e2, ... ) + local result + + if *es = 0 then return "()" + + result := "" + every result ||:= !es || ", " + + return code_gen("(", result[1:-2], ")") + +end + +procedure Pdco(e, es[]) # e{e1, e2, ... } + local result + + if *es = 0 then return code_gen(e, "{}") + + result := "" + every result ||:= !es || ", " + + return code_gen(e, "{", result[1:-2], "}") + +end + +procedure Proc(n, vs[]) # procedure n(v1, v2, ...) + local result, v + + if *vs = 0 then write("procedure ", n, "()") + + result := "" + every v := !vs do + if \v == "[]" then result[-2:0] := v || ", " + else result ||:= (\v | "") || ", " + + write("procedure ", n, "(", result[1:-2], ")") + + return + +end + +procedure Record(n, fs[]) # record n(f1, f2, ...) + local result, field + + if *fs = 0 then write("record ", n, "()") + + result := "" + every field := !fs do + result ||:= (\field | "") || ", " + + write("record ", n, "(", result[1:-2], ")") + + return + +end + +procedure Repeat(e) # repeat e + + return code_gen("repeat ", e) + +end + +procedure Return(e) # return e + + return code_gen("return ", e) + +end + +procedure Rlit(r) # r + + return r + +end + +procedure Scan(e1, e2) # e1 ? e2 + + return code_gen("(", e1 , " ? ", e2, ")") + +end + +procedure Section(op, e1, e2, e3) # e1[e2 op e3] + + return code_gen(e1, "[", e2, op, e3, "]") + +end + +procedure Slit(s) # "s" + + return image(s) + +end + +procedure Static(vs[]) # static v1, v2, .. + local result + + result := "" + every result ||:= !vs || ", " + + write("static ", result[1:-2]) + + return + +end + +procedure Subscript(e1, e2) # e1[e2] + + return code_gen(e1, "[", e2, "]") + +end + +procedure Suspend(e) # suspend e + + return code_gen("suspend ", e) + +end + +procedure SuspendDo(e1, e2) # suspend e1 do e2 + + return code_gen("suspend ", e1, " do ", e2) + +end + +procedure To(e1, e2) # e1 to e2 + + return code_gen("(", e1, " to ", e2, ")") + +end + +procedure ToBy(e1, e2, e3) # e1 to e2 by e3 + + return code_gen("(", e1, " to ", e2, " by ", e3, ")") + +end + +procedure Repalt(e) # |e + + return code_gen("(|", e, ")") + +end + +procedure Unop(op, e) # op e + + return code_gen("(", op, e, ")") + +end + +procedure Until(e) # until e + + return code_gen("until ", e) + +end + +procedure UntilDo(e1, e2) # until e1 do e2 + + return code_gen("until ", e1, " do ", e2) + +end + +procedure Var(v) # v + + return v + +end + +procedure While(e) # while e + + return code_gen("while ", e) + +end + +procedure WhileDo(e1, e2) # while e1 do e2 + + return code_gen("while ", e1, " do ", e2) + +end diff --git a/ipl/procs/identity.icn b/ipl/procs/identity.icn new file mode 100644 index 0000000..8bf82c0 --- /dev/null +++ b/ipl/procs/identity.icn @@ -0,0 +1,35 @@ +############################################################################ +# +# File: identity.icn +# +# Subject: Procedures to produce identities for Icon types +# +# Author: Ralph E. Griswold +# +# Date: September 2, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure produces an "identity" value for types that have one. +# +############################################################################ + +procedure identity(x) + + return case x of { + "null": &null + "integer": 0 + "real": 0.0 + "string": "" + "cset": '' + "list": [] + "set": set() + "table": table() + default: fail + } + +end diff --git a/ipl/procs/ifncs.icn b/ipl/procs/ifncs.icn new file mode 100644 index 0000000..2be1bf1 --- /dev/null +++ b/ipl/procs/ifncs.icn @@ -0,0 +1,859 @@ +############################################################################ +# +# File: ifncs.icn +# +# Subject: Procedure wrappers for function tracing +# +# Author: Ralph E. Griswold +# +# Date: September 28, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These are procedure wrappers for use in Icon function tracing. Don't let +# the apparent recursion fool you. +# +############################################################################ +# +# See also: iftrace.icn +# +############################################################################ + +procedure active() + static __fnc_Active + initial __fnc_Active := proc("Active", 0) + suspend __fnc_Active() +end + +procedure alert(a[]) + static __fnc_Alert + initial __fnc_Alert := proc("Alert", 0) + suspend __fnc_Alert ! a +end + +procedure bg(a[]) + static __fnc_Bg + initial __fnc_Bg := proc("Bg", 0) + suspend __fnc_Bg ! a +end + +procedure clip(a[]) + static __fnc_Clip + initial __fnc_Clip := proc("Clip", 0) + suspend __fnc_Clip ! a +end + +procedure clone(a[]) + static __fnc_Clone + initial __fnc_Clone := proc("Clone", 0) + suspend __fnc_Clone ! a +end + +procedure color(a[]) + static __fnc_Color + initial __fnc_Color := proc("Color", 0) + suspend __fnc_Color ! a +end + +procedure colorValue(a[]) + static __fnc_ColorValue + initial __fnc_ColorValue := proc("ColorValue", 0) + suspend __fnc_ColorValue ! a +end + +procedure copyArea(a[]) + static __fnc_CopyArea + initial __fnc_CopyArea := proc("CopyArea", 0) + suspend __fnc_CopyArea ! a +end + +procedure couple(a1, a2) + static __fnc_Couple + initial __fnc_Couple := proc("Couple", 0) + suspend __fnc_Couple(a1, a2) +end + +procedure drawArc(a[]) + static __fnc_DrawArc + initial __fnc_DrawArc := proc("DrawArc", 0) + suspend __fnc_DrawArc ! a +end + +procedure drawCircle(a[]) + static __fnc_DrawCircle + initial __fnc_DrawCircle := proc("DrawCircle", 0) + suspend __fnc_DrawCircle ! a +end + +procedure drawCurve(a[]) + static __fnc_DrawCurve + initial __fnc_DrawCurve := proc("DrawCurve", 0) + suspend __fnc_DrawCurve ! a +end + +procedure drawImage(a[]) + static __fnc_DrawImage + initial __fnc_DrawImage := proc("DrawImage", 0) + suspend __fnc_DrawImage ! a +end + +procedure drawLine(a[]) + static __fnc_DrawLine + initial __fnc_DrawLine := proc("DrawLine", 0) + suspend __fnc_DrawLine ! a +end + +procedure drawPoint(a[]) + static __fnc_DrawPoint + initial __fnc_DrawPoint := proc("DrawPoint", 0) + suspend __fnc_DrawPoint ! a +end + +procedure drawPolygon(a[]) + static __fnc_DrawPolygon + initial __fnc_DrawPolygon := proc("DrawPolygon", 0) + suspend __fnc_DrawPolygon ! a +end + +procedure drawRectangle(a[]) + static __fnc_DrawRectangle + initial __fnc_DrawRectangle := proc("DrawRectangle", 0) + suspend __fnc_DrawRectangle ! a +end + +procedure drawSegment(a[]) + static __fnc_DrawSegment + initial __fnc_DrawSegment := proc("DrawSegment", 0) + suspend __fnc_DrawSegment ! a +end + +procedure drawString(a[]) + static __fnc_DrawString + initial __fnc_DrawString := proc("DrawString", 0) + suspend __fnc_DrawString ! a +end + +procedure eraseArea(a[]) + static __fnc_EraseArea + initial __fnc_EraseArea := proc("EraseArea", 0) + suspend __fnc_EraseArea ! a +end + +procedure event(a[]) + static __fnc_Event + initial __fnc_Event := proc("Event", 0) + suspend __fnc_Event ! a +end + +procedure fg(a[]) + static __fnc_Fg + initial __fnc_Fg := proc("Fg", 0) + suspend __fnc_Fg ! a +end + +procedure fillArc(a[]) + static __fnc_FillArc + initial __fnc_FillArc := proc("FillArc", 0) + suspend __fnc_FillArc ! a +end + +procedure fillCircle(a[]) + static __fnc_FillCircle + initial __fnc_FillCircle := proc("FillCircle", 0) + suspend __fnc_FillCircle ! a +end + +procedure fillPolygon(a[]) + static __fnc_FillPolygon + initial __fnc_FillPolygon := proc("FillPolygon", 0) + suspend __fnc_FillPolygon ! a +end + +procedure fillRectangle(a[]) + static __fnc_FillRectangle + initial __fnc_FillRectangle := proc("FillRectangle", 0) + suspend __fnc_FillRectangle ! a +end + +procedure font(a[]) + static __fnc_Font + initial __fnc_Font := proc("Font", 0) + suspend __fnc_Font ! a +end + +procedure freeColor(a[]) + static __fnc_FreeColor + initial __fnc_FreeColor := proc("FreeColor", 0) + suspend __fnc_FreeColor ! a +end + +procedure gotoRC(a[]) + static __fnc_GotoRC + initial __fnc_GotoRC := proc("GotoRC", 0) + suspend __fnc_GotoRC ! a +end + +procedure gotoXY(a[]) + static __fnc_GotoXY + initial __fnc_GotoXY := proc("GotoXY", 0) + suspend __fnc_GotoXY ! a +end + +procedure lower(a[]) + static __fnc_Lower + initial __fnc_Lower := proc("Lower", 0) + suspend __fnc_Lower ! a +end + +procedure newColor(a[]) + static __fnc_NewColor + initial __fnc_NewColor := proc("NewColor", 0) + suspend __fnc_NewColor ! a +end + +procedure paletteChars(a[]) + static __fnc_PaletteChars + initial __fnc_PaletteChars := proc("PaletteChars", 0) + suspend __fnc_PaletteChars ! a +end + +procedure paletteColor(a[]) + static __fnc_PaletteColor + initial __fnc_PaletteColor := proc("PaletteColor", 0) + suspend __fnc_PaletteColor ! a +end + +procedure paletteKey(a[]) + static __fnc_PaletteKey + initial __fnc_PaletteKey := proc("PaletteKey", 0) + suspend __fnc_PaletteKey ! a +end + +procedure pattern(a[]) + static __fnc_Pattern + initial __fnc_Pattern := proc("Pattern", 0) + suspend __fnc_Pattern ! a +end + +procedure pending(a[]) + static __fnc_Pending + initial __fnc_Pending := proc("Pending", 0) + suspend __fnc_Pending ! a +end + +procedure pixel(a[]) + static __fnc_Pixel + initial __fnc_Pixel := proc("Pixel", 0) + suspend __fnc_Pixel ! a +end + +procedure queryPointer(a1) + static __fnc_QueryPointer + initial __fnc_QueryPointer := proc("QueryPointer", 0) + suspend __fnc_QueryPointer(a1) +end + +procedure raise(a[]) + static __fnc_Raise + initial __fnc_Raise := proc("Raise", 0) + suspend __fnc_Raise ! a +end + +procedure readImage(a[]) + static __fnc_ReadImage + initial __fnc_ReadImage := proc("ReadImage", 0) + suspend __fnc_ReadImage ! a +end + +procedure textWidth(a[]) + static __fnc_TextWidth + initial __fnc_TextWidth := proc("TextWidth", 0) + suspend __fnc_TextWidth ! a +end + +procedure uncouple(a1) + static __fnc_Uncouple + initial __fnc_Uncouple := proc("Uncouple", 0) + suspend __fnc_Uncouple(a1) +end + +procedure wAttrib(a[]) + static __fnc_WAttrib + initial __fnc_WAttrib := proc("WAttrib", 0) + suspend __fnc_WAttrib ! a +end + +procedure wDefault(a[]) + static __fnc_WDefault + initial __fnc_WDefault := proc("WDefault", 0) + suspend __fnc_WDefault ! a +end + +procedure wFlush(a[]) + static __fnc_WFlush + initial __fnc_WFlush := proc("WFlush", 0) + suspend __fnc_WFlush ! a +end + +procedure wSync(a1) + static __fnc_WSync + initial __fnc_WSync := proc("WSync", 0) + suspend __fnc_WSync(a1) +end + +procedure writeImage(a[]) + static __fnc_WriteImage + initial __fnc_WriteImage := proc("WriteImage", 0) + suspend __fnc_WriteImage ! a +end + +procedure Abs(a1) + static __fnc_abs + initial __fnc_abs := proc("abs", 0) + suspend __fnc_abs(a1) +end + +procedure Acos(a1) + static __fnc_acos + initial __fnc_acos := proc("acos", 0) + suspend __fnc_acos(a1) +end + +procedure Any(a1, a2, a3, a4) + static __fnc_any + initial __fnc_any := proc("any", 0) + suspend __fnc_any(a1, a2, a3, a4) +end + +procedure Args(a1) + static __fnc_args + initial __fnc_args := proc("args", 0) + suspend __fnc_args(a1) +end + +procedure Asin(a1) + static __fnc_asin + initial __fnc_asin := proc("asin", 0) + suspend __fnc_asin(a1) +end + +procedure Atan(a1, a2) + static __fnc_atan + initial __fnc_atan := proc("atan", 0) + suspend __fnc_atan(a1, a2) +end + +procedure Bal(a1, a2, a3, a4, a5, a6) + static __fnc_bal + initial __fnc_bal := proc("bal", 0) + suspend __fnc_bal(a1, a2, a3, a4, a5, a6) +end + +procedure Callout(a[]) + static __fnc_callout + initial __fnc_callout := proc("callout", 0) + suspend __fnc_callout ! a +end + +procedure Center(a1, a2, a3) + static __fnc_center + initial __fnc_center := proc("center", 0) + suspend __fnc_center(a1, a2, a3) +end + +procedure Char(a1) + static __fnc_char + initial __fnc_char := proc("char", 0) + suspend __fnc_char(a1) +end + +procedure Chdir(a1) + static __fnc_chdir + initial __fnc_chdir := proc("chdir", 0) + suspend __fnc_chdir(a1) +end + +procedure Close(a1) + static __fnc_close + initial __fnc_close := proc("close", 0) + suspend __fnc_close(a1) +end + +procedure Collect(a1, a2) + static __fnc_collect + initial __fnc_collect := proc("collect", 0) + suspend __fnc_collect(a1, a2) +end + +procedure Copy(a1) + static __fnc_copy + initial __fnc_copy := proc("copy", 0) + suspend __fnc_copy(a1) +end + +procedure Cos(a1) + static __fnc_cos + initial __fnc_cos := proc("cos", 0) + suspend __fnc_cos(a1) +end + +procedure Cset(a1) + static __fnc_cset + initial __fnc_cset := proc("cset", 0) + suspend __fnc_cset(a1) +end + +procedure Delay(a1) + static __fnc_delay + initial __fnc_delay := proc("delay", 0) + suspend __fnc_delay(a1) +end + +procedure Delete(a1, a2) + static __fnc_delete + initial __fnc_delete := proc("delete", 0) + suspend __fnc_delete(a1, a2) +end + +procedure Detab(a[]) + static __fnc_detab + initial __fnc_detab := proc("detab", 0) + suspend __fnc_detab ! a +end + +procedure Display(a1, a2) + static __fnc_display + initial __fnc_display := proc("display", 0) + suspend __fnc_display(a1, a2) +end + +procedure Dtor(a1) + static __fnc_dtor + initial __fnc_dtor := proc("dtor", 0) + suspend __fnc_dtor(a1) +end + +procedure Entab(a[]) + static __fnc_entab + initial __fnc_entab := proc("entab", 0) + suspend __fnc_entab ! a +end + +procedure Errorclear() + static __fnc_errorclear + initial __fnc_errorclear := proc("errorclear", 0) + suspend __fnc_errorclear() +end + +procedure Exit(a1) + static __fnc_exit + initial __fnc_exit := proc("exit", 0) + suspend __fnc_exit(a1) +end + +procedure Exp(a1) + static __fnc_exp + initial __fnc_exp := proc("exp", 0) + suspend __fnc_exp(a1) +end + +procedure Find(a1, a2, a3, a4) + static __fnc_find + initial __fnc_find := proc("find", 0) + suspend __fnc_find(a1, a2, a3, a4) +end + +procedure Flush(a1) + static __fnc_flush + initial __fnc_flush := proc("flush", 0) + suspend __fnc_flush(a1) +end + +procedure Function() + static __fnc_function + initial __fnc_function := proc("function", 0) + suspend __fnc_function() +end + +procedure Get(a1) + static __fnc_get + initial __fnc_get := proc("get", 0) + suspend __fnc_get(a1) +end + +procedure Getch() + static __fnc_getch + initial __fnc_getch := proc("getch", 0) + suspend __fnc_getch() +end + +procedure Getche() + static __fnc_getche + initial __fnc_getche := proc("getche", 0) + suspend __fnc_getche() +end + +procedure Getenv(a1) + static __fnc_getenv + initial __fnc_getenv := proc("getenv", 0) + suspend __fnc_getenv(a1) +end + +procedure Iand(a1, a2) + static __fnc_iand + initial __fnc_iand := proc("iand", 0) + suspend __fnc_iand(a1, a2) +end + +procedure Icom(a1) + static __fnc_icom + initial __fnc_icom := proc("icom", 0) + suspend __fnc_icom(a1) +end + +procedure Image(a1) + static __fnc_image + initial __fnc_image := proc("image", 0) + suspend __fnc_image(a1) +end + +procedure Insert(a1, a2, a3) + static __fnc_insert + initial __fnc_insert := proc("insert", 0) + suspend __fnc_insert(a1, a2, a3) +end + +procedure Integer(a1) + static __fnc_integer + initial __fnc_integer := proc("integer", 0) + suspend __fnc_integer(a1) +end + +procedure Ior(a1, a2) + static __fnc_ior + initial __fnc_ior := proc("ior", 0) + suspend __fnc_ior(a1, a2) +end + +procedure Ishift(a1, a2) + static __fnc_ishift + initial __fnc_ishift := proc("ishift", 0) + suspend __fnc_ishift(a1, a2) +end + +procedure Ixor(a1, a2) + static __fnc_ixor + initial __fnc_ixor := proc("ixor", 0) + suspend __fnc_ixor(a1, a2) +end + +procedure Kbhit() + static __fnc_kbhit + initial __fnc_kbhit := proc("kbhit", 0) + suspend __fnc_kbhit() +end + +procedure Key(a1) + static __fnc_key + initial __fnc_key := proc("key", 0) + suspend __fnc_key(a1) +end + +procedure Left(a1, a2, a3) + static __fnc_left + initial __fnc_left := proc("left", 0) + suspend __fnc_left(a1, a2, a3) +end + +procedure List(a1, a2) + static __fnc_list + initial __fnc_list := proc("list", 0) + suspend __fnc_list(a1, a2) +end + +procedure Loadfunc(a1, a2) + static __fnc_loadfunc + initial __fnc_loadfunc := proc("loadfunc", 0) + suspend __fnc_loadfunc(a1, a2) +end + +procedure Log(a1, a2) + static __fnc_log + initial __fnc_log := proc("log", 0) + suspend __fnc_log(a1, a2) +end + +procedure Many(a1, a2, a3, a4) + static __fnc_many + initial __fnc_many := proc("many", 0) + suspend __fnc_many(a1, a2, a3, a4) +end + +procedure Map(a1, a2, a3) + static __fnc_map + initial __fnc_map := proc("map", 0) + suspend __fnc_map(a1, a2, a3) +end + +procedure Match(a1, a2, a3, a4) + static __fnc_match + initial __fnc_match := proc("match", 0) + suspend __fnc_match(a1, a2, a3, a4) +end + +procedure Member(a1, a2) + static __fnc_member + initial __fnc_member := proc("member", 0) + suspend __fnc_member(a1, a2) +end + +procedure Move(a1) + static __fnc_move + initial __fnc_move := proc("move", 0) + suspend __fnc_move(a1) +end + +procedure Name(a1) + static __fnc_name + initial __fnc_name := proc("name", 0) + suspend __fnc_name(a1) +end + +procedure Numeric(a1) + static __fnc_numeric + initial __fnc_numeric := proc("numeric", 0) + suspend __fnc_numeric(a1) +end + +procedure Open(a[]) + static __fnc_open + initial __fnc_open := proc("open", 0) + suspend __fnc_open ! a +end + +procedure Ord(a1) + static __fnc_ord + initial __fnc_ord := proc("ord", 0) + suspend __fnc_ord(a1) +end + +procedure Pop(a1) + static __fnc_pop + initial __fnc_pop := proc("pop", 0) + suspend __fnc_pop(a1) +end + +procedure Pos(a1) + static __fnc_pos + initial __fnc_pos := proc("pos", 0) + suspend __fnc_pos(a1) +end + +procedure Proc(a1, a2) + static __fnc_proc + initial __fnc_proc := proc("proc", 0) + suspend __fnc_proc(a1, a2) +end + +procedure Pull(a1) + static __fnc_pull + initial __fnc_pull := proc("pull", 0) + suspend __fnc_pull(a1) +end + +procedure Push(a[]) + static __fnc_push + initial __fnc_push := proc("push", 0) + suspend __fnc_push ! a +end + +procedure Put(a[]) + static __fnc_put + initial __fnc_put := proc("put", 0) + suspend __fnc_put ! a +end + +procedure Read(a1) + static __fnc_read + initial __fnc_read := proc("read", 0) + suspend __fnc_read(a1) +end + +procedure Reads(a1, a2) + static __fnc_reads + initial __fnc_reads := proc("reads", 0) + suspend __fnc_reads(a1, a2) +end + +procedure Real(a1) + static __fnc_real + initial __fnc_real := proc("real", 0) + suspend __fnc_real(a1) +end + +procedure Remove(a1) + static __fnc_remove + initial __fnc_remove := proc("remove", 0) + suspend __fnc_remove(a1) +end + +procedure Rename(a1, a2) + static __fnc_rename + initial __fnc_rename := proc("rename", 0) + suspend __fnc_rename(a1, a2) +end + +procedure Repl(a1, a2) + static __fnc_repl + initial __fnc_repl := proc("repl", 0) + suspend __fnc_repl(a1, a2) +end + +procedure Reverse(a1) + static __fnc_reverse + initial __fnc_reverse := proc("reverse", 0) + suspend __fnc_reverse(a1) +end + +procedure Right(a1, a2, a3) + static __fnc_right + initial __fnc_right := proc("right", 0) + suspend __fnc_right(a1, a2, a3) +end + +procedure Rtod(a1) + static __fnc_rtod + initial __fnc_rtod := proc("rtod", 0) + suspend __fnc_rtod(a1) +end + +procedure Runerr(a[]) + static __fnc_runerr + initial __fnc_runerr := proc("runerr", 0) + suspend __fnc_runerr ! a +end + +procedure Seek(a1, a2) + static __fnc_seek + initial __fnc_seek := proc("seek", 0) + suspend __fnc_seek(a1, a2) +end + +procedure Seq(a1, a2) + static __fnc_seq + initial __fnc_seq := proc("seq", 0) + suspend __fnc_seq(a1, a2) +end + +procedure Set(a1) + static __fnc_set + initial __fnc_set := proc("set", 0) + suspend __fnc_set(a1) +end + +procedure Sin(a1) + static __fnc_sin + initial __fnc_sin := proc("sin", 0) + suspend __fnc_sin(a1) +end + +procedure Sort(a1, a2) + static __fnc_sort + initial __fnc_sort := proc("sort", 0) + suspend __fnc_sort(a1, a2) +end + +procedure Sortf(a1, a2) + static __fnc_sortf + initial __fnc_sortf := proc("sortf", 0) + suspend __fnc_sortf(a1, a2) +end + +procedure Sqrt(a1) + static __fnc_sqrt + initial __fnc_sqrt := proc("sqrt", 0) + suspend __fnc_sqrt(a1) +end + +procedure Stop(a[]) + static __fnc_stop + initial __fnc_stop := proc("stop", 0) + suspend __fnc_stop ! a +end + +procedure String(a1) + static __fnc_string + initial __fnc_string := proc("string", 0) + suspend __fnc_string(a1) +end + +procedure System(a1) + static __fnc_system + initial __fnc_system := proc("system", 0) + suspend __fnc_system(a1) +end + +procedure Tab(a1) + static __fnc_tab + initial __fnc_tab := proc("tab", 0) + suspend __fnc_tab(a1) +end + +procedure Table(a1) + static __fnc_table + initial __fnc_table := proc("table", 0) + suspend __fnc_table(a1) +end + +procedure Tan(a1) + static __fnc_tan + initial __fnc_tan := proc("tan", 0) + suspend __fnc_tan(a1) +end + +procedure Trim(a1, a2) + static __fnc_trim + initial __fnc_trim := proc("trim", 0) + suspend __fnc_trim(a1, a2) +end + +procedure Type(a1) + static __fnc_type + initial __fnc_type := proc("type", 0) + suspend __fnc_type(a1) +end + +procedure Upto(a1, a2, a3, a4) + static __fnc_upto + initial __fnc_upto := proc("upto", 0) + suspend __fnc_upto(a1, a2, a3, a4) +end + +procedure Variable(a1) + static __fnc_variable + initial __fnc_variable := proc("variable", 0) + suspend __fnc_variable(a1) +end + +procedure Where(a1) + static __fnc_where + initial __fnc_where := proc("where", 0) + suspend __fnc_where(a1) +end + +procedure Write(a[]) + static __fnc_write + initial __fnc_write := proc("write", 0) + suspend __fnc_write ! a +end + +procedure Writes(a[]) + static __fnc_writes + initial __fnc_writes := proc("writes", 0) + suspend __fnc_writes ! a +end + diff --git a/ipl/procs/iftrace.icn b/ipl/procs/iftrace.icn new file mode 100644 index 0000000..1b12623 --- /dev/null +++ b/ipl/procs/iftrace.icn @@ -0,0 +1,71 @@ +############################################################################ +# +# File: iftrace.icn +# +# Subject: Procedures to trace Icon function calls +# +# Author: Stephen B. Wampler +# +# Date: July 14, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Contributor: Ralph E. Griswold +# +############################################################################ +# +# These procedures provide tracing for Icon functions by using procedure +# wrappers to call the functions. +# +# iftrace(fncs[]) sets tracing for a list of function names. +# +############################################################################ +# +# Note: The functions that can be traced and their procedure wrappers should +# be organized and coordinated to assure consistency and to allow for +# extended function repertoire. +# +############################################################################ +# +# Links: ifncs +# +############################################################################ + +invocable all + +link ifncs + +procedure iftrace(args[]) #: trace built-in functions + local nextarg, arg + + every set_trace(!args) + + return +end + +procedure set_trace(vf) + local vp + static traceset, case1, case2 + + initial { + traceset := set() + every insert(traceset, function()) + case1 := &lcase || &ucase + case2 := &ucase || &lcase + } + + if member(traceset,vf) then { + &trace := -1 # have to also trace all procedures! + vp := vf + # reverse case of first letter + vp[1] := map(vp[1], case1, case2) + variable(vp) :=: variable(vf) + return + } + else fail + +end diff --git a/ipl/procs/image.icn b/ipl/procs/image.icn new file mode 100644 index 0000000..24f23b1 --- /dev/null +++ b/ipl/procs/image.icn @@ -0,0 +1,323 @@ +############################################################################ +# +# File: image.icn +# +# Subject: Procedures to produce images of Icon values +# +# Authors: Michael Glass, Ralph E. Griswold, and David Yost +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# The procedure Image(x,style) produces a string image of the value x. +# The value produced is a generalization of the value produced by +# the Icon function image(x), providing detailed information about +# structures. The value of style determines the formatting and +# order of processing: +# +# 1 indented, with ] and ) at end of last item (default) +# 2 indented, with ] and ) on new line +# 3 puts the whole image on one line +# 4 as 3, but with structures expanded breadth-first instead of +# depth-first as for other styles. +# +############################################################################ +# +# Tags are used to uniquely identify structures. A tag consists +# of a letter identifying the type followed by an integer. The tag +# letters are L for lists, R for records, S for sets, and T for +# tables. The first time a structure is encountered, it is imaged +# as the tag followed by a colon, followed by a representation of +# the structure. If the same structure is encountered again, only +# the tag is given. +# +# An example is +# +# a := ["x"] +# push(a,a) +# t := table() +# push(a,t) +# t[a] := t +# t["x"] := [] +# t[t] := a +# write(Image(t)) +# +# which produces +# +# T1:[ +# "x"->L1:[], +# L2:[ +# T1, +# L2, +# "x"]->T1, +# T1->L2] +# +# On the other hand, Image(t,3) produces +# +# T1:["x"->L1:[],L2:[T1,L2,"x"]->T1,T1->L2] +# +# Note that a table is represented as a list of entry and assigned +# values separated by ->. +# +############################################################################ +# +# Problem: +# +# The procedure here really is a combination of an earlier version and +# two modifications to it. It should be re-organized to combine the +# presentation style and order of expansion. +# +# Bug: +# +# Since the table of structures used in a call to Image is local to +# that call, but the numbers used to generate unique tags are static to +# the procedures that generate tags, the same structure gets different +# tags in different calls of Image. +# +############################################################################ + +procedure Image(x,style,done,depth,nonewline) + local retval + + if style === 4 then return Imageb(x) # breadth-first style + + /style := 1 + /done := table() + if /depth then depth := 0 + else depth +:= 2 + if (style ~= 3 & depth > 0 & /nonewline) then + retval := "\n" || repl(" ",depth) + else retval := "" + if match("record ",image(x)) then retval ||:= Rimage(x,done,depth,style) + else { + retval ||:= + case type(x) of { + "list": Limage(x,done,depth,style) + "table": Timage(x,done,depth,style) + "set": Simage(x,done,depth,style) + default: image(x) + } + } + depth -:= 2 + return retval +end + +# list image +# +procedure Limage(a,done,depth,style) + static i + local s, tag + initial i := 0 + if \done[a] then return done[a] + done[a] := tag := "L" || (i +:= 1) + if *a = 0 then s := tag || ":[]" else { + s := tag || ":[" + every s ||:= Image(!a,style,done,depth) || "," + s[-1] := endof("]",depth,style) + } + return s +end + +# record image +# +procedure Rimage(x,done,depth,style) + static i + local s, tag + initial i := 0 + s := image(x) + # might be record constructor + if match("record constructor ",s) then return s + if \done[x] then return done[x] + done[x] := tag := "R" || (i +:= 1) + s ?:= (="record " & (":" || (tab(upto('(') + 1)))) + if *x = 0 then s := tag || s || ")" else { + s := tag || s + every s ||:= Image(!x,style,done,depth) || "," + s[-1] := endof(")",depth,style) + } + return s +end + +# set image +# +procedure Simage(S,done,depth,style) + static i + local s, tag + initial i := 0 + if \done[S] then return done[S] + done[S] := tag := "S" || (i +:= 1) + if *S = 0 then s := tag || ":[]" else { + s := tag || ":[" + every s ||:= Image(!S,style,done,depth) || "," + s[-1] := endof("]",depth,style) + } + return s +end + +# table image +# +procedure Timage(t,done,depth,style) + static i + local s, tag, a, a1 + initial i := 0 + if \done[t] then return done[t] + done[t] := tag := "T" || (i +:= 1) + if *t = 0 then s := tag || ":[]" else { + a := sort(t,3) + s := tag || ":[" + while s ||:= Image(get(a),style,done,depth) || "->" || + Image(get(a),style,done,depth,1) || "," + s[-1] := endof("]",depth,style) + } + return s +end + +procedure endof (s,depth,style) + if style = 2 then return "\n" || repl(" ",depth) || "]" + else return "]" +end + +############################################################################ +# +# What follows is the breadth-first expansion style +# + +procedure Imageb(x, done, tags) + local t + + if /done then { + done := [set()] # done[1] actually done; done[2:0] pseudo-done + tags := table() # unique label for each structure + } + + if member(!done, x) then return tags[x] + + t := tagit(x, tags) # The tag for x if structure; image(x) if not + + if /tags[x] then + return t # Wasn't a structure + else { + insert(done[1], x) # Mark x as actually done + return case t[1] of { + "R": rimageb(x, done, tags) # record + "L": limageb(x, done, tags) # list + "T": timageb(x, done, tags) # table + "S": simageb(x, done, tags) # set + } + } +end + + +# Create and return a tag for a structure, and save it in tags[x]. +# Otherwise, if x is not a structure, return image(x). +# +procedure tagit(x, tags) + local ximage, t, prefix + static serial + initial serial := table(0) + + if \tags[x] then return tags[x] + + if match("record constructor ", ximage := image(x)) then + return ximage # record constructor + + if match("record ", t := ximage) | + ((t := type(x)) == ("list" | "table" | "set")) then { + prefix := map(t[1], "rlts", "RLTS") + return tags[x] := prefix || (serial[prefix] +:=1) + } # structure + + else return ximage # anything else +end + + +# Every component sub-structure of the current structure gets tagged +# and added to a pseudo-done set. +# +procedure defer_image(a, done, tags) + local x, t + t := set() + every x := !a do { + tagit(x, tags) + if \tags[x] then insert(t, x) # if x actually is a sub-structure + } + put(done, t) + return +end + + +# Create the image of every component of the current structure. +# Sub-structures get deleted from the local pseudo-done set before +# we actually create their image. +# +procedure do_image(a, done, tags) + local x, t + t := done[-1] + suspend (delete(t, x := !a), Imageb(x, done, tags)) +end + + +# list image +# +procedure limageb(a, done, tags) + local s + if *a = 0 then s := tags[a] || ":[]" else { + defer_image(a, done, tags) + s := tags[a] || ":[" + every s ||:= do_image(a, done, tags) || "," + s[-1] := "]" + pull(done) + } + return s +end + +# record image +# +procedure rimageb(x, done, tags) + local s + s := image(x) + s ?:= (="record " & (":" || (tab(upto('(') + 1)))) + if *x = 0 then s := tags[x] || s || ")" else { + defer_image(x, done, tags) + s := tags[x] || s + every s ||:= do_image(x, done, tags) || "," + s[-1] := ")" + pull(done) + } + return s +end + +# set image +# +procedure simageb(S, done, tags) + local s + if *S = 0 then s := tags[S] || ":[]" else { + defer_image(S, done, tags) + s := tags[S] || ":[" + every s ||:= do_image(S, done, tags) || "," + s[-1] := "]" + pull(done) + } + return s +end + +# table image +# +procedure timageb(t, done, tags) + local s, a + if *t = 0 then s := tags[t] || ":[]" else { + a := sort(t,3) + defer_image(a, done, tags) + s := tags[t] || ":[" + while s ||:= do_image([get(a)], done, tags) || "->" || + do_image([get(a)], done, tags) || "," + s[-1] := "]" + pull(done) + } + return s +end diff --git a/ipl/procs/inbits.icn b/ipl/procs/inbits.icn new file mode 100644 index 0000000..5e4a4d1 --- /dev/null +++ b/ipl/procs/inbits.icn @@ -0,0 +1,58 @@ +############################################################################ +# +# File: inbits.icn +# +# Subject: Procedure to read variable-length characters +# +# Author: Richard L. Goerwitz +# +# Date: November 3, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.2 +# +############################################################################ +# +# This procedure, inbits(), re-imports data converted into writable +# form by outbits(). See the file outbits.icn for all the whys and +# hows. +# +############################################################################ +# +# See also: outbits.icn +# +############################################################################ + +procedure inbits(f, len) + + local i, byte, old_byte_mask + static old_byte, old_len, byte_length + initial { + old_byte := old_len := 0 + byte_length := 8 + } + + old_byte_mask := (0 < 2^old_len - 1) | 0 + old_byte := iand(old_byte, old_byte_mask) + i := ishift(old_byte, len-old_len) + + len -:= (len > old_len) | { + old_len -:= len + return i + } + + while byte := ord(reads(f)) do { + i := ior(i, ishift(byte, len-byte_length)) + len -:= (len > byte_length) | { + old_len := byte_length-len + old_byte := byte + return i + } + } + +end diff --git a/ipl/procs/indices.icn b/ipl/procs/indices.icn new file mode 100644 index 0000000..a05e68b --- /dev/null +++ b/ipl/procs/indices.icn @@ -0,0 +1,69 @@ +############################################################################ +# +# File: indices.icn +# +# Subject: Procedure to produce indices +# +# Author: Ralph E. Griswold +# +# Date: June 2, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# indices(spec, last) +# produces a list of the integers given by the +# specification spec, which is a common separated list +# of either positive integers or integer spans, as in +# +# "1,3-10, ..." +# +# If last is specified, it it used for a span of +# the form "10-". +# +# In an integer span, the low and high values need not +# be in order. For example, "1-10" and "10-1" +# are equivalent. Similarly, indices need not be +# in order, as in "3-10, 1, ..." +# +# And empty value, as in "10,,12" is ignored. +# +# indices() fails if the specification is syntactically +# erroneous or if it contains a value less than 1. +# +############################################################################ + +procedure indices(spec, last) #: generate indices + local item, hi, lo, result + + if \last then last := (0 < integer(last)) | fail + + result := set() + + spec ? { + while item := tab(upto(',') | 0) do { + if item := integer(item) then + ((insert(result, 0 < item)) | fail) + else if *item = 0 then { + move(1) | break + next + } + else item ? { + (lo := (0 < integer(tab(upto('-')))) | fail) + move(1) + hi := (if pos(0) then last else + ((0 < integer(tab(0)) | fail))) + /hi := lo + if lo > hi then lo :=: hi + every insert(result, lo to hi) + } + move(1) | break + } + } + + return sort(result) + +end diff --git a/ipl/procs/inserts.icn b/ipl/procs/inserts.icn new file mode 100644 index 0000000..f24cbb5 --- /dev/null +++ b/ipl/procs/inserts.icn @@ -0,0 +1,26 @@ +############################################################################ +# +# File: inserts.icn +# +# Subject: Procedures to build tables with duplicate keys +# +# Author: Robert J. Alexander +# +# Date: September 7, 1990 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# inserts() -- Inserts values into a table in which the same key can +# have more than one value (i.e., duplicate keys). The value of each +# element is a list of inserted values. The table must be created +# with default value &null. +# + +procedure inserts(tabl,key,value) + (/tabl[key] := [value]) | put(tabl[key],value) + return tabl +end diff --git a/ipl/procs/intstr.icn b/ipl/procs/intstr.icn new file mode 100644 index 0000000..4d407aa --- /dev/null +++ b/ipl/procs/intstr.icn @@ -0,0 +1,37 @@ +############################################################################ +# +# File: intstr.icn +# +# Subject: Procedure to create string from bits +# +# Author: Robert J. Alexander +# +# Date: April 2, 1990 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# intstr() -- Creates a string consisting of the raw bits in the low +# order "size" bytes of integer i. +# +# This procedure is normally used for processing of binary data +# to be written to a file. +# +# Note that if large integers are supported, this procedure still +# will not work for integers larger than the implementation defined +# word size due to the shifting in of zero-bits from the left in the +# right shift operation. +# + +procedure intstr(i,size) + local s + s := "" + every 1 to size do { + s := char(iand(i,16rFF)) || s + i := ishift(i,-8) + } + return s +end diff --git a/ipl/procs/io.icn b/ipl/procs/io.icn new file mode 100644 index 0000000..9a0e60e --- /dev/null +++ b/ipl/procs/io.icn @@ -0,0 +1,805 @@ +############################################################################ +# +# File: io.icn +# +# Subject: Procedures for input and output +# +# Author: Ralph E. Griswold +# +# Date: March 25, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Contributors: Paul Abrahams, Bob Alexander, Will Evans, David A. Gamey, +# Richard L. Goerwitz, Will Menagarini, Charles Shartsis, +# and Gregg Townsend. +# +############################################################################ +# +# They provide facilities for handling input, output, and files. +# +# There are other modules in the Icon program library that deal with +# input and output. They are not included here because they conflict +# with procedures here or each other. +# +############################################################################ +# +# Requires: Appropriate operating system for procedures used. Some +# require loadfunc(). +# +############################################################################ +# +# Links: random, strings +# +############################################################################ +# +# File copying: +# +# fcopy(fn1, fn2) copies a file named fn1 to file named fn2. +# +############################################################################ +# +# File existence: +# +# exists(name) succeeds if name exists as a file but fails +# otherwise. +# +# directory(name) succeeds if name exists as a directory +# but fails otherwise. +# +############################################################################ +# +# File lists: +# +# filelist(s,x) returns a list of the file names that match the +# specification s. If x is nonnull, any directory +# is stripped off. At present it only works for +# UNIX. Users of other platforms are invited to add +# code for their platforms. +# +############################################################################ +# +# Reading and writing files: +# +# filetext(f) reads the lines of f into a list and returns that +# list +# +# readline(file) assembles backslash-continued lines from the specified +# file into a single line. If the last line in a file +# ends in a backslash, that character is included in the +# last line read. +# +# splitline(file, line, limit) +# splits line into pieces at first blank after +# the limit, appending a backslash to identify split +# lines (if a line ends in a backslash already, that's +# too bad). The pieces are written to the specified file. +# +############################################################################ +# +# Buffered input and output: +# +# ClearOut() remove contents of output buffer without writing +# Flush() flush output buffer +# GetBack() get back line writen +# LookAhead() look ahead at next line +# PutBack(s) put back a line +# Read() read a line +# ReadAhead(n) read ahead n lines +# Write(s) write a line +# +############################################################################ +# +# Path searching: +# +# dopen(s) opens and returns the file s on DPATH. +# +# dpath(s) returns the path to s on DPATH. +# +# Both fail if the file is not found. +# +# pathfind(fname, path) +# returns the full path of fname if found along the list of +# directories in "path", else fails. If no path is given, +# getenv("DPATH") is the default. As is customary in Icon +# path searching, "." is prepended to the path. +# +# pathload(fname, entry) +# calls loadfunc() to load entry from the file fname found on the +# function path. If the file or entry point cannot be found, the +# program is aborted. The function path consists of the current +# directory, then getenv("FPATH"), to which iconx automatically +# appends the directory containing the standard libcfunc.so file. +# +############################################################################ +# +# Parsing file names: +# +# suffix() parses a hierarchical file name, returning a 2-element +# list: [prefix,suffix]. E.g. suffix("/a/b/c.d") -> +# ["/a/b/c","d"] +# +# tail() parses a hierarchical file name, returning a 2-element +# list: [head,tail]. E.g. tail("/a/b/c.d") -> +# ["/a/b","c.d"]. +# +# components() parses a hierarchical file name, returning a list of +# all directory names in the file path, with the file +# name (tail) as the last element. For example, +# components("/a/b/c.d") -> ["/","a","b","c.d"]. +# +############################################################################ +# +# Temporary files: +# +# tempfile(prefix, suffix, path, len) +# produces a "temporary" file that can be written. The name +# is chosen so as not to overwrite an existing file. +# The prefix and suffix are prepended and appended, respectively, +# to a randomly chosen number. They default to the empty +# string. The path is prepended to the file name; its default +# is "." The randomly chosen number is fit into a field of len +# (default 8) by truncation or right filling with zeros as +# necessary. +# +# It is the user's responsibility to remove the file when it is +# no longer needed. +# +# tempname(prefix, suffix, path, len) +# produces the name of a temporary file. +# +############################################################################ +# +# DOS helpers: +# +# dosdir(diropts) generates records of type dirinfo for each file +# found in the directory, failing when no more files +# are available, as in +# +# every dirent := dosdir("*.*") do .... +# +# known problems: +# +# When used to traverse directories and sub-directories in nested every +# loops it doesn't work as expected - requires further investigation. +# Bypass by building lists of the subdirectories to be traversed. +# +# dosdirlist( dpath, dpart2, infotab ) +# returns a list containing the qualified file names for files +# in dpath and matching file patterns and/or options specified +# in dpart2. For example, +# +# dirlist := dosdirlist( "..", "*.* /o:n /a:r-d" ) +# +# returns a list of all read-only-non-directory files in the +# parent directory on a MS-DOS compatible system. +# +# If the optional infotab is specified, +# +# (1) it must be a table or a run time error will result +# (2) the contents of the table will be updated as follows +# a dirinfo record will be created for each filename +# (3) the filename will be the key to the table +# +# For example, +# +# t := table() +# dirlist := dosdirlist( "..", "*.* /o:n /a:r-d", t ) +# maxsize := 0 ; every maxsize <:= t[!dirlist].size +# +# calculates the maximum size of the files. +# +# dosfiles(pfn) accepts a DOS filename possibly containing wildcards. +# The filename can also include a drive letter and path. +# If the filename ends in "\" or ":", "*.*" is appended. +# The result sequence is a sequence of the filenames +# corresponding to pfn. +# +# dosname(s) converts a file name by truncating to the +# MS-DOS 8.3 format. Forward slashes are converted +# to backslashes and all letters are converted to +# lower case. +# +# Every disk drive on a MS-DOS system has a "working directory", which is +# the directory referred to by any references to that drive that don't begin +# with a backslash (& so are either direct references to that working +# directory, or paths relative to it). There is also 1 "current drive", & +# its working directory is called the "current working directory". Any paths +# that don't explicitly specify a drive refer to the current drive. For +# example, "name.ext" refers to the current drive's working directory, aka +# the current working directory; "\name.ext" refers to the current drive's +# root directory; & "d:name.ext" refers to the working directory on d:. +# +# It's reasonable to want to inquire any of these values. The CD command +# displays both, in the form of a complete path to the current working +# directory. However, passing such a path to either CD or the Icon function +# chdir() doesn't change to that dir on that drive; it changes that drive's +# working directory to the specified path without changing the current +# drive. The command to change the current drive is the system() function +# of a command consisting of just the drive letter followed by ":". +# +# This affects the design of inquiry functions. They could be implemented +# with system( "CD >" || ( name := tempname() ) ) & read(open(name)), but +# because this requires a slow disk access (which could fail on a full disk) +# it's unacceptable to need to do that *twice*, once for the drive & again +# for the dir; so if that strategy were used, it'd be necessary to return a +# structure containing the current drive & the working directory. That +# structure, whether table, list, or string, would then need to be either +# indexed or string-scanned to get the individual values, making the code +# cumbersome & obscure. It's much better to have 2 separate inquiry +# functions, 1 for each value; but for this to be acceptably efficient, it's +# necessary to forgo the disk access & implement the functions with +# interrupts. +# +# getdrive() returns the current drive as a lowercase string with +# the ":". +# +# getwd("g") +# getwd("g:") return the working directory on drive g:, or +# fail if g: doesn't exist. getwd() returns the current +# working directory. getwd(...) always returns +# lowercase. It prepends the relevant drive letter +# with its colon; that's harmless in a chdir(), & useful +# in an open(). +# +# DOS_FileParts(s) takes a DOS file name and returns +# a record containing various representations of +# the file name and its components. The name +# given is returned in the fullname field. +# Fields that cannot be determined are returned +# as empty strings. +# +############################################################################ + +link random +link strings + +global buffer_in, buffer_out, Eof + +record _DOS_FileParts_(fullname,devpath,device,path,name,extension) +record dirinfo( name, ext, size, date, time ) + +procedure ClearOut() #: remove contents of output buffer + + buffer_out := [] + +end + +procedure DOS_FileParts(filename) #: parse DOSfile name + +local dev, path, name, ext, p, d + +filename ? { + dev := 1( tab( upto(':') ), move(1) ) | "" + d := &pos - 1 + tab(0) + } ? { + p := 1 + path := tab( ( every p := upto('\\') + 1 ) | p ) + tab(0) + } ? { + name := 1( tab( upto('.') ), move(1) ) | tab(0) + ext := tab(0) + } + + +return _DOS_FileParts_(filename,filename[1:d + p],dev,path,name,ext) +end + +procedure Flush() #: flush output buffer + + while write(pull(buffer_out)) + + return + +end + +procedure GetBack() #: get back line written + + return get(buffer_out) + +end + +procedure LookAhead() #: look at next line + + return buffer_in[1] + +end + +procedure PutBack(s) #: put back line read + + push(buffer_in,s) + + return + +end + +procedure Read() #: read a line in buffered mode + + initial{ + buffer_in := [] + } + + if *buffer_in = 0 then + put(buffer_in,read()) | (Eof := 1) + return get(buffer_in) + +end + +procedure ReadAhead(n) #: read ahead + + while *buffer_in < n do + put(buffer_in,read()) | { + Eof := 1 + fail + } + + return + +end + +procedure Write(s) #: write in buffered mode + + initial buffer_out := [] + + push(buffer_out,s) + + return s + +end + +procedure components(s,separator) #: get components of file name + local x,head + /separator := "/" + x := tail(s,separator) + return case head := x[1] of { + separator: [separator] + "": [] +# C. Shartsis: 4/23/95 - fix for MS-DOS +# default: components(head) + default: components(head, separator) + } ||| ([&null ~=== x[2]] | []) +end + +procedure dopen(s) #: open file on DPATH + local file, paths, path + + if file := open(s) then return file # look in current directory + + paths := getenv("DPATH") | fail + + s := "/" || s # platform-specific + + paths ? { + while path := tab(upto(' ') | 0) do { + if file := open(path || s) then return file + tab(many(' ')) | break + } + } + + fail + +end + +procedure dosdir( diropts ) #: process DOS directory + local de, line + + static tempfn, tempf, dosdir_ver + +initial { + + close(open(tempfn := tempname(),"w")) + + system("ver > " || tempfn) + + (tempf := open(tempfn,"r")) | + stop("Unable to open ",tempfn," from dosdir.") + + while line := read(tempf) do + + if find("MS-DOS",line) then + if find("6.20",line) then + dosdir_ver := dosdir_62 + else + dosdir_ver := dosdir_xx + + close(tempf) + system("erase " || tempfn) + } + +close(open(tempfn := tempname(),"w")) # ensure useable file + +system("dir " || diropts || " > " || tempfn) # get dir + +tempf := open(tempfn,"r") # open file + +while line := map(read(tempf)) do { + line ? + if de := dosdir_ver() then + suspend de + else + next + } + +close(tempf) +system("erase " || tempfn) +end + +procedure dosdir_62() + +static nb +local de + +initial nb := ~' ' + +if *&subject = 43 & (tab(any(nb)), move(-1)) then { + de := dirinfo() + (de.name := trim(move(8)), move(1), + de.ext := trim(move(3)), move(1), + de.size := move(13), move(1), + de.date := move(8), move(2), + de.time := tab(0)) + every de.size ?:= 1(tab(upto(',')),move(1)) || tab(0) + return de + } +end + +procedure dosdir_xx() + +static nb +local de + +initial nb := ~' ' + +if *&subject = 39 & (tab(any(nb)), move(-1)) then { + de := dirinfo() + (de.name := trim(move(8)), move(1), + de.ext := trim(move(3)), move(1), + de.size := integer(move(9)), move(1), + de.date := move(8), move(2), + de.time := tab(0)) + return de + } +end + +procedure dosdirlist( #: get list of DOS directory + dpath, dpart2, infotab + ) +local dl, di, fn + +if type(\infotab) ~== "table" then + runerr( 124, infotab ) + +dpath ||:= dpath[-1] ~== "\\" +/dpart2 := "*.*" + +dl := [] +every di := dosdir( dpath || dpart2 ) do + if not ( di.name == ("." | "..") ) then { + put( dl, fn := ( dpath || di.name || "." || trim(di.ext) ) ) + (\infotab)[fn] := di + } + + return dl + +end + +$ifdef _MSDOS + +procedure dosfiles(pfn) #: DOS file names + local asciiz, fnr, prefix, k, name + local ds, dx, result, fnloc, string_block + +# Get Disk Transfer Address; filename locn is 30 beyond that. + + result := Int86([16r21, 16r2f00] ||| list(7,0)) + # pointer arithmetic wrong: fnloc := 16 * result[8] + result[3]+ 30 + fnloc := ishift( result[8], 16 ) + result[3] + 30 + +# Get the generalized filename. + + fnr := reverse(pfn) + k := upto("\\:", fnr) | *fnr + 1 + prefix := reverse(fnr[k:0]) + name := "" ~== reverse(fnr[1:k]) | "*.*" + +# Get the first file in the sequence. + + asciiz := prefix || name || "\x00" + Poke(string_block := GetSpace(*asciiz), asciiz) | + stop( "dosfiles(): GetSpace() failed." ) + # pointer arithmetic wrong: ds := string_block / 16 + # pointer arithmetic wrong: dx := string_block % 16 + ds := ishift( string_block, -16 ) + dx := iand( string_block, 16rffff ) + result := Int86([16r21, 16r4e00, 0, 0, dx, 0, 0, 0, ds]) + FreeSpace(string_block) + case result[2] of { + 0 : {} + 18 : fail + default : stop("I/O Error ", result[2]) + } + suspend prefix || extract_name(fnloc) + +# Get the remaining files in the sequence. + + while Int86([16r21, 16r4f00, 0, 0, 0, 0, 0, 0, 0])[2] = 0 do + suspend prefix || extract_name(fnloc) +end + +$endif + +procedure dosname(namein) #: convert file name to DOS format + + local prefix, base, extension, pair, extended_name + + namein := replace(namein, "/", "\\") + pair := tail(namein, "\\") + prefix := pair[1] + extended_name := pair[2] + pair := suffix(extended_name) + base := pair[1] + extension := pair[2] + + base := base[1:9] + extension := extension[1:4] + + return map(prefix || "\\" || base || "." || extension) + +end + +procedure dpath(s) #: full path to file on DPATH + local file, paths, path, result + + if exists(s) then return s # look in current directory + + paths := getenv("DPATH") | fail + + s := "/" || s # platform-specific + + paths ? { + while path := tab(upto(' ') | 0) do { + if exists(result := path || s) then return result + tab(many(' ')) | break + } + } + + fail + +end + +procedure exists(name) #: test file existence + + return close(open(name)) + +end + +procedure directory(name) #: succeed if name is a directory + +$ifdef _MS_WINDOWS + if fattrib(name, "status")[1] == "d" then + return name + else + fail +$else + if close(open(name || "/.")) then + return name + else + fail +$endif + +end + +$ifdef _MSDOS + +procedure extract_name(fnloc) + local asciiz + asciiz := Peek(fnloc, 13) + return asciiz[1:upto("\x00", asciiz)] +end + +$endif + +procedure fcopy(fn1,fn2) #: copy file + local f1, f2, buf + + f1 := open(fn1,"ru") | stop("Can't open ",fn1) + f2 := open(fn2,"wu") | stop("Can't open ",fn2," for writing") + while buf := reads(f1,512) do writes(f2,buf) + every close(f2 | f1) + return fn2 +end + +procedure filelist(spec, x) #: get list of files + local flist, ls, f + + /spec := "" + + flist := [] + + if &features == "UNIX" then { + ls := open("ls " || spec || " 2>/dev/null", "p") + every f := !ls do { + if \x then f ?:= { + while tab(upto("/") + 1) + tab(0) + } + put(flist, f) + } + close(ls) + return flist + } + else fail # don't take control away from caller + +end + +procedure filetext(f) #: read file into list + local input, file, text + + input := open(f) | stop("cannot open input file") + + text := [] + + while put(text,read(input)) + + close(input) + + return text + +end + +$ifdef _MSDOS + +procedure getdrive() #: get current DOS drive + return &lcase[iand( Int86([33,16r1900,0,0,0,0,0,0,0])[2], 255 )+1] || ":" +end + +procedure getwd(drive) #: get DOS working directory + local A, dx, si, cf, ds + + + A := GetSpace(64) | stop( "getwd(): GetSpace() failed." ) + dx := ("36r" || !\drive) - 9 | 0 + si := iand( A, 16rffff ); ds := ishift( A, -16 ) + cf := !Int86([33,16r4700,0,0,dx,si,0,0,ds]) % 2 + Peek( A , 64 ) ? path := tab(many(~'\0')) | "" + FreeSpace(A) + cf = 0 | fail + return ( map(!\drive) || ":" | getdrive() ) || "\\" || map(path) +end + +$endif + + +procedure pathfind(fname, path) #: find file on path + local f, dir, fullname + + $ifdef _UNIX + $define PSEP ' :' + $else + $define PSEP ' ' + $endif + + fname ? { + if ="/" & close(open(fname)) then + return fname # full absolute path works + while tab(upto('/') + 1) + fname := tab(0) # get final component of path + } + + /path := getenv("DPATH") + /path := "" + path := ". " || path + path ? while not pos(0) do { + dir := tab(upto(PSEP) | 0) + fullname := trim(dir, '/') || "/" || fname + if close(open(fullname)) then + return fullname + tab(many(PSEP)) + } + fail +end + +procedure pathload(fname, entry) #: load C function from $FPATH + local path, found + + path := getenv("FPATH") | "." + found := pathfind(fname, path) + + if /found then + stop ("cannot find \"", fname, "\" on path \". ", path, "\"") + + return loadfunc(found, entry) # aborts if unsuccessful +end + +procedure readline(file) #: assemble backslash-continued lines + local line + + line := read(file) | fail + + while line[-1] == "\\" do + line := line[1:-1] || read(file) | break + + return line + +end + +procedure splitline(file,line,limit) #: split line into pieces + local i, j + + if *line = 0 then { # don't fail to write empty line + write(file,line) + return + } + while *line > limit do { + line ?:= { + i := j := 0 + every i := find(" ") do { # find a point to split + if i >= limit then break + else j := i + } + if j = 0 then { # can't split + write(file,line) + return + } + write(file,tab(j + 1),"\\") + tab(0) # update line + } + } + if *line > 0 then write(file,line) # the rest + + return + +end + +procedure suffix(s,separator) #: find suffix of file name + local i + /separator := "." + i := *s + 1 + every i := find(separator,s) + return [s[1:i],s[(*s >= i) + 1:0] | &null] +end + +procedure tail(s,separator) #: find tail of file name + local i + /separator := "/" + i := 0 + every i := find(separator,s) + return [s[1:i + (i <= 1 | 0)],"" ~== s[i + 1:0] | &null] +end + +procedure tempfile( #: get temporary file + prefix, suffix, path, len + ) + local name + + name := tempname(prefix, suffix, path, len) + + return open(name, "w") | fail + +end + +procedure tempname( #: get temporary file name + prefix, suffix, path, len + ) + local name, file + + /prefix := "" + /suffix := "" + /path := "." + prefix := path || "/" || prefix + /len := 8 + + randomize() + + repeat { + ?1 # change &random + name := prefix || left(&random, 8, "0") || suffix + if not exists(name) then return name + } + +end diff --git a/ipl/procs/iolib.icn b/ipl/procs/iolib.icn new file mode 100644 index 0000000..fed62bb --- /dev/null +++ b/ipl/procs/iolib.icn @@ -0,0 +1,567 @@ +############################################################################ +# +# File: iolib.icn +# +# Subject: Procedures for termlib support +# +# Author: Richard L. Goerwitz (with help from Norman Azadian) +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.13 +# +############################################################################ +# +# The following library represents a series of rough functional +# equivalents to the standard UNIX low-level termcap routines. It is +# not meant as an exact termlib clone. Nor is it enhanced to take +# care of magic cookie terminals, terminals that use \D in their +# termcap entries, or archaic terminals that require padding. This +# library is geared mainly for use with ANSI and VT-100 devices. +# Note that this file may, in most instances, be used in place of the +# older UNIX-only itlib.icn file. It essentially replaces the DOS- +# only itlibdos routines. For DOS users not familiar with the whole +# notion of generalized screen I/O, I've included extra documentation +# below. Please read it. +# +# The sole disadvantage of this over the old itlib routines is that +# iolib.icn cannot deal with archaic or arcane UNIX terminals and/or +# odd system file arrangements. Note that because these routines +# ignore padding, they can (unlike itlib.icn) be run on the NeXT and +# other systems which fail to implement the -g option of the stty +# command. Iolib.icn is also simpler and faster than itlib.icn. +# +# I want to thank Norman Azadian for suggesting the whole idea of +# combining itlib.icn and itlibdos.icn into one distribution, for +# suggesting things like letting drive specifications appear in DOS +# TERMCAP environment variables, and for finding several bugs (e.g. +# the lack of support for %2 and %3 in cm). Although he is loathe +# to accept this credit, I think he deserves it. +# +############################################################################ +# +# Contents: +# +# setname(term) +# Use only if you wish to initialize itermlib for a terminal +# other than what your current environment specifies. "Term" is the +# name of the termcap entry to use. Normally this initialization is +# done automatically, and need not concern the user. +# +# getval(id) +# Works something like tgetnum, tgetflag, and tgetstr. In the +# spirit of Icon, all three have been collapsed into one routine. +# Integer valued caps are returned as integers, strings as strings, +# and flags as records (if a flag is set, then type(flag) will return +# "true"). Absence of a given capability is signalled by procedure +# failure. +# +# igoto(cm,destcol,destline) - NB: default 1 offset (*not* zero)! +# Analogous to tgoto. "Cm" is the cursor movement command for +# the current terminal, as obtained via getval("cm"). Igoto() +# returns a string which, when output via iputs, will cause the +# cursor to move to column "destcol" and line "destline." Column and +# line are always calculated using a *one* offset. This is far more +# Iconish than the normal zero offset used by tgoto. If you want to +# go to the first square on your screen, then include in your program +# "iputs(igoto(getval("cm"),1,1))." +# +# iputs(cp,affcnt) +# Equivalent to tputs. "Cp" is a string obtained via getval(), +# or, in the case of "cm," via igoto(getval("cm"),x,y). Affcnt is a +# count of affected lines. It is completely irrelevant for most +# modern terminals, and is supplied here merely for the sake of +# backward compatibility with itlib, a UNIX-only version of these +# routines (one which handles padding on archaic terminals). +# +############################################################################ +# +# Notes for MS-DOS users: +# +# There are two basic reasons for using the I/O routines +# contained in this package. First, by using a set of generalized +# routines, your code will become much more readable. Secondly, by +# using a high level interface, you can avoid the cardinal +# programming error of hard coding things like screen length and +# escape codes into your programs. +# +# To use this collection of programs, you must do two things. +# First, you must add the line "device=ansi.sys" (or the name of some +# other driver, like zansi.sys, nansi.sys, or nnansi.sys [=new +# nansi.sys]) to your config.sys file. Secondly, you must add two +# lines to your autoexec.bat file: 1) "set TERM=ansi-mono" and 2) +# "set TERMCAP=\location\termcap." The purpose of setting the TERM +# variable is to tell this program what driver you are using. If you +# have a color system, you could use "ansi-color" instead of +# "ansi-mono," although for compatibility with a broader range of +# users, it would perhaps be better to stick with mono. The purpose +# of setting TERMCAP is to make it possible to determine where the +# termcap database file is located. The termcap file (which should +# have been packed with this library as termcap.dos) is a short +# database of all the escape sequences used by the various terminal +# drivers. Set TERMCAP so that it reflects the location of this file +# (which should be renamed as termcap, for the sake of consistency +# across UNIX and MS-DOS spectra). If desired, you can also try +# using termcap2.dos. Certain games work a lot better using this +# alternate file. To try it out, rename it to termcap, and set +# the environment variable TERMCAP to its location. +# +# Although the authors make no pretense of providing here a +# complete introduction to the format of the termcap database file, +# it will be useful, we believe, to explain a few basic facts about +# how to use this program in conjunction with it. If, say, you want +# to clear the screen, add the line, +# +# iputs(getval("cl")) +# +# to your program. The function iputs() outputs screen control +# sequences. Getval retrieves a specific sequence from the termcap +# file. The string "cl" is the symbol used in the termcap file to +# mark the code used to clear the screen. By executing the +# expression "iputs(getval("cl"))," you are 1) looking up the "cl" +# (clear) code in the termcap database entry for your terminal, and +# the 2) outputting that sequence to the screen. +# +# Some other useful termcap symbols are "ce" (clear to end of +# line), "ho" (go to the top left square on the screen), "so" (begin +# standout mode), and "se" (end standout mode). To output a +# boldfaced string, str, to the screen, you would write - +# +# iputs(getval("so")) +# writes(str) +# iputs(getval("se")) +# +# You can also write "writes(getval("so") || str || getval("se")), +# but this would make reimplementation for UNIX terminals that +# require padding rather difficult. +# +# It is also heartily to be recommended that MS-DOS programmers +# try not to assume that everyone will be using a 25-line screen. +# Most terminals are 24-line. Some 43. Some have variable window +# sizes. If you want to put a status line on, say, the 2nd-to-last +# line of the screen, then determine what that line is by executing +# "getval("li")." The termcap database holds not only string-valued +# sequences, but numeric ones as well. The value of "li" tells you +# how many lines the terminal has (compare "co," which will tell you +# how many columns). To go to the beginning of the second-to-last +# line on the screen, type in: +# +# iputs(igoto(getval("cm"), 1, getval("li")-1)) +# +# The "cm" capability is a special capability, and needs to be output +# via igoto(cm,x,y), where cm is the sequence telling your computer +# to move the cursor to a specified spot, x is the column, and y is +# the row. The expression "getval("li")-1" will return the number of +# the second-to-last line on your screen. +# +############################################################################ +# +# Requires: UNIX or MS-DOS, co-expressions +# +############################################################################ +# +# See also: itlib.icn, iscreen.icn +# +############################################################################ + + +global tc_table, isDOS +record true() + + +procedure check_features() + + initial { + + if find("UNIX",&features) then + isDOS := &null + else if find("MS-DOS", &features) then + isDOS := 1 + else stop("check_features: OS not (yet?) supported.") + + find("expressi",&features) | + er("check_features","co-expressions not implemented - &$#!",1) + } + + return + +end + + + +procedure setname(name) + + # Sets current terminal type to "name" and builds a new termcap + # capability database (residing in tc_table). Fails if unable to + # find a termcap entry for terminal type "name." If you want it + # to terminate with an error message under these circumstances, + # comment out "| fail" below, and uncomment the er() line. + + #tc_table is global + + check_features() + + tc_table := table() + tc_table := maketc_table(getentry(name)) | fail + # er("setname","no termcap entry found for "||name,3) + return "successfully reset for terminal " || name + +end + + + +procedure getname() + + # Getname() first checks to be sure we're running under DOS or + # UNIX, and, if so, tries to figure out what the current terminal + # type is, checking successively the value of the environment + # variable TERM, and then (under UNIX) the output of "tset -". + # Terminates with an error message if the terminal type cannot be + # ascertained. DOS defaults to "mono." + + local term, tset_output + + check_features() + + if \isDOS then { + term := getenv("TERM") | "mono" + } + else { + if not (term := getenv("TERM")) then { + tset_output := open("/bin/tset -","pr") | + er("getname","can't find tset command",1) + term := !tset_output + close(tset_output) + } + } + + return \term | + er("getname","can't seem to determine your terminal type",1) + +end + + + +procedure er(func,msg,errnum) + + # short error processing utility + write(&errout,func,": ",msg) + exit(errnum) + +end + + + +procedure getentry(name, termcap_string) + + # "Name" designates the current terminal type. Getentry() scans + # the current environment for the variable TERMCAP. If the + # TERMCAP string represents a termcap entry for a terminal of type + # "name," then getentry() returns the TERMCAP string. Otherwise, + # getentry() will check to see if TERMCAP is a file name. If so, + # getentry() will scan that file for an entry corresponding to + # "name." If the TERMCAP string does not designate a filename, + # getentry() will scan the termcap file for the correct entry. + # Whatever the input file, if an entry for terminal "name" is + # found, getentry() returns that entry. Otherwise, getentry() + # fails. + + local isFILE, f, getline, line, nm, ent1, ent2, entry + static slash, termcap_names + initial { + if \isDOS then { + slash := "\\" + termcap_names := ["termcap","termcap.dos","termcap2.dos"] + } + else { + slash := "/" + termcap_names := ["/etc/termcap"] + } + } + + + # You can force getentry() to use a specific termcap file by cal- + # ling it with a second argument - the name of the termcap file + # to use instead of the regular one, or the one specified in the + # termcap environment variable. + /termcap_string := getenv("TERMCAP") + + if \isDOS then { + if \termcap_string then { + if termcap_string ? ( + not ((tab(any(&letters)), match(":")) | match(slash)), + pos(1) | tab(find("|")+1), =name) + then { + # if entry ends in tc= then add in the named tc entry + termcap_string ?:= tab(find("tc=")) || + # Recursively fetch the new termcap entry w/ name trimmed. + # Note that on the next time through name won't match the + # termcap environment variable, so getentry() will look for + # a termcap file. + (move(3), getentry(tab(find(":"))) ? + (tab(find(":")+1), tab(0))) + return termcap_string + } + else isFILE := 1 + } + } + else { + if \termcap_string then { + if termcap_string ? ( + not match(slash), pos(1) | tab(find("|")+1), =name) + then { + # if entry ends in tc= then add in the named tc entry + termcap_string ?:= tab(find("tc=")) || + # Recursively fetch the new termcap entry w/ name trimmed. + (move(3), getentry(tab(find(":")), "/etc/termcap") ? + (tab(find(":")+1), tab(0))) + return termcap_string + } + else isFILE := 1 + } + } + + # The logic here probably isn't clear. The idea is to try to use + # the termcap environment variable successively as 1) a termcap en- + # try and then 2) as a termcap file. If neither works, 3) go to + # the /etc/termcap file. The else clause here does 2 and, if ne- + # cessary, 3. The "\termcap_string ? (not match..." expression + # handles 1. + + if \isFILE # if find(slash, \termcap_string) + then f := open(\termcap_string) + /f := open(!termcap_names) | + er("getentry","I can't access your termcap file. Read iolib.icn.",1) + + getline := create read_file(f) + + while line := @getline do { + if line ? (pos(1) | tab(find("|")+1), =name, any(':|')) then { + entry := "" + while (\line | @getline) ? { + if entry ||:= 1(tab(find(":")+1), pos(0)) + then { + close(f) + # if entry ends in tc= then add in the named tc entry + entry ?:= tab(find("tc=")) || + # recursively fetch the new termcap entry + (move(3), getentry(tab(find(":"))) ? + # remove the name field from the new entry + (tab(find(":")+1), tab(0))) + return entry + } + else { + \line := &null # must precede the next line + entry ||:= trim(trim(tab(0),'\\'),':') + } + } + } + } + + close(f) + er("getentry","can't find and/or process your termcap entry",3) + +end + + + +procedure read_file(f) + + # Suspends all non #-initial lines in the file f. + # Removes leading tabs and spaces from lines before suspending + # them. + + local line + + \f | er("read_tcap_file","no valid termcap file found",3) + while line := read(f) do { + match("#",line) & next + line ?:= (tab(many('\t ')) | &null, tab(0)) + suspend line + } + + fail + +end + + + +procedure maketc_table(entry) + + # Maketc_table(s) (where s is a valid termcap entry for some + # terminal-type): Returns a table in which the keys are termcap + # capability designators, and the values are the entries in + # "entry" for those designators. + + local k, v, str, decoded_value + + /entry & er("maketc_table","no entry given",8) + if entry[-1] ~== ":" then entry ||:= ":" + + /tc_table := table() + + entry ? { + + tab(find(":")+1) # tab past initial (name) field + + while tab((find(":")+1) \ 1) ? { + &subject == "" & next + if k := 1(move(2), ="=") then { + # Get rid of null padding information. Iolib can't + # handle it (unlike itlib.icn). Leave star in. It + # indicates a real dinosaur terminal, and will later + # prompt an abort. + str := ="*" | ""; tab(many(&digits)) + decoded_value := Decode(str || tab(find(":"))) + } + else if k := 1(move(2), ="#") + then decoded_value := integer(tab(find(":"))) + else if k := 1(tab(find(":")), pos(-1)) + then decoded_value := true() + else er("maketc_table", "your termcap file has a bad entry",3) + /tc_table[k] := decoded_value + &null + } + } + + return tc_table + +end + + + +procedure getval(id) + + /tc_table := maketc_table(getentry(getname())) | + er("getval","can't make a table for your terminal",4) + + return \tc_table[id] | fail + # er("getval","the current terminal doesn't support "||id,7) + +end + + + +procedure Decode(s) + + # Does things like turn ^ plus a letter into a genuine control + # character. + + local new_s, chr, chr2 + + new_s := "" + + s ? { + + while new_s ||:= tab(upto('\\^')) do { + chr := move(1) + if chr == "\\" then { + new_s ||:= { + case chr2 := move(1) of { + "\\" : "\\" + "^" : "^" + "E" : "\e" + "b" : "\b" + "f" : "\f" + "n" : "\n" + "r" : "\r" + "t" : "\t" + default : { + if any(&digits,chr2) then { + char(integer("8r"||chr2||move(2 to 0 by -1))) | + er("Decode","bad termcap entry",3) + } + else chr2 + } + } + } + } + else new_s ||:= char(ord(map(move(1),&lcase,&ucase)) - 64) + } + new_s ||:= tab(0) + } + + return new_s + +end + + + +procedure igoto(cm,col,line) + + local colline, range, increment, padding, str, outstr, chr, x, y + + if \col > (tc_table["co"]) | \line > (tc_table["li"]) then { + colline := string(\col) || "," || string(\line) | string(\col|line) + range := "(" || tc_table["co"]-1 || "," || tc_table["li"]-1 || ")" + er("igoto",colline || " out of range " || (\range|""),9) + } + + # Use the Iconish 1;1 upper left corner & not the C-ish 0 offsets + increment := -1 + outstr := "" + + cm ? { + while outstr ||:= tab(find("%")) do { + tab(match("%")) + if padding := integer(tab(any('23'))) + then chr := (="d" | "d") + else chr := move(1) + if case \chr of { + "." : outstr ||:= char(line + increment) + "+" : outstr ||:= char(line + ord(move(1)) + increment) + "d" : { + str := string(line + increment) + outstr ||:= right(str, \padding, "0") | str + } + } + then line :=: col + else { + case chr of { + "n" : line := ixor(line,96) & col := ixor(col,96) + "i" : increment := 0 + "r" : line :=: col + "%" : outstr ||:= "%" + "B" : line := ior(ishift(line / 10, 4), line % 10) + ">" : { + x := move(1); y := move(1) + line > ord(x) & line +:= ord(y) + &null + } + } | er("goto","bad termcap entry",5) + } + } + return outstr || tab(0) + } + +end + + + +procedure iputs(cp, affcnt) + + # Writes cp to the screen. Use this instead of writes() for + # compatibility with itlib (a UNIX-only version which can handle + # albeit inelegantly) terminals that need padding. + + static num_chars + initial num_chars := &digits ++ '.' + + type(cp) == "string" | + er("iputs","you can't iputs() a non-string value!",10) + + cp ? { + if tab(many(num_chars)) & ="*" then + stop("iputs: iolib can't use terminals that require padding.") + writes(tab(0)) + } + + return + +end diff --git a/ipl/procs/iscreen.icn b/ipl/procs/iscreen.icn new file mode 100644 index 0000000..bc8a686 --- /dev/null +++ b/ipl/procs/iscreen.icn @@ -0,0 +1,312 @@ +############################################################################ +# +# File: iscreen.icn +# +# Subject: Procedures for screen functions +# +# Author: Richard L. Goerwitz +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.28 +# +############################################################################ +# +# This file contains some rudimentary screen functions for use with +# itlib.icn (termlib-like routines for Icon). +# +# clear() - clears the screen (tries several methods) +# emphasize() - initiates emphasized (usu. = reverse) mode +# boldface() - initiates bold mode +# blink() - initiates blinking mode +# normal() - resets to normal mode +# message(s) - displays message s on 2nd-to-last line +# underline() - initiates underline mode +# status_line(s,s2,p) - draws status line s on the 3rd-to-last +# screen line; if s is too short for the terminal, s2 is used; +# if p is nonnull then it either centers, left-, or right-justi- +# fies, depending on the value, "c," "l," or "r." +# clear_emphasize() - horrible way of clearing the screen to all- +# emphasize mode; necessary for many terminals +# +############################################################################ +# +# Requires: UNIX +# +############################################################################ +# +# Links: itlib (or your OS-specific port of itlib) +# +############################################################################ +# +# See also: boldface.icn +# +############################################################################ + +link itlib + +procedure clear() + + # Clears the screen. Tries several methods. + local i + + normal() + if not iputs(getval("cl")) + then iputs(igoto(getval("cm"),1,1) | getval("ho")) + 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)) + } + return + +end + + + +procedure boldface() + + static bold_str, cookie_str + initial { + if bold_str := getval("md") + then cookie_str := repl(getval("le"|"bc") | "\b", getval("mg")) + else { + # One global procedure value substituted for another. + boldface := emphasize + return emphasize() + } + } + + normal() + iputs(\bold_str) + iputs(\cookie_str) + return + +end + + + +procedure blink() + + static blink_str, cookie_str + initial { + if blink_str := getval("mb") + then cookie_str := + repl(getval("le"|"bc") | "\b", getval("mg")) + else { + # One global procedure value substituted for another. + blink := emphasize + return emphasize() + } + } + + normal() + iputs(\blink_str) + iputs(\cookie_str) + return + +end + + + +procedure emphasize() + + static emph_str, cookie_str + initial { + if emph_str := getval("so") + then cookie_str := repl(getval("le"|"bc") | "\b", getval("sg")) + else { + if emph_str := getval("mr") + then cookie_str := repl(getval("le"|"bc") | "\b", getval("mg")) + else if emph_str := getval("us") + then cookie_str := repl(getval("le"|"bc") | "\b", getval("ug")) + } + } + + normal() + iputs(\emph_str) + iputs(\cookie_str) + return + +end + + + +procedure underline() + + static underline_str, cookie_str + initial { + if underline_str := getval("us") + then cookie_str := repl(getval("le"|"bc") | "\b", getval("ug")) + } + + normal() + iputs(\underline_str) + iputs(\cookie_str) + return + +end + + + +procedure normal(mode) + + static UN_emph_str, emph_cookie_str, + UN_underline_str, underline_cookie_str, + UN_bold_str, bold_cookie_str + + initial { + + # Find out code to turn off emphasize (reverse video) mode. + if UN_emph_str := getval("se") then + # Figure out how many backspaces we need to erase cookies. + emph_cookie_str := repl(getval("le"|"bc") | "\b", getval("sg")) + else UN_emph_str := "" + + # Finally, figure out how to turn off underline mode. + if UN_underline_str := (UN_emph_str ~== getval("ue")) then + underline_cookie_str := repl(getval("le"|"bc")|"\b", getval("ug")) + else UN_underline_str := "" + + # Figure out how to turn off boldface mode. + if UN_bold_str := + (UN_underline_str ~== (UN_emph_str ~== getval("me"))) then + # Figure out how many backspaces we need to erase cookies. + bold_cookie_str := repl(getval("le"|"bc") | "\b", getval("mg")) + else UN_bold_str := "" + + } + + iputs("" ~== UN_emph_str) & + iputs(\emph_cookie_str) + + iputs("" ~== UN_underline_str) & + iputs(\underline_cookie_str) + + iputs("" ~== UN_bold_str) & + iputs(\bold_cookie_str) + + return + +end + + + +procedure status_line(s,s2,p) + + # Writes a status line on the terminal's third-to-last line + # The only necessary argument is s. S2 (optional) is used + # for extra narrow screens. In other words, by specifying + # s2 you give status_line an alternate, shorter status string + # to display, in case the terminal isn't wide enough to sup- + # port s. If p is nonnull, then the status line is either + # centered (if equal to "c"), left justified ("l"), or right + # justified ("r"). + + local width + + /s := ""; /s2 := ""; /p := "c" + width := getval("co") + if *s > width then { + (*s2 < width, s := s2) | + er("status_line","Your terminal is too narrow.",4) + } + + case p of { + "c" : s := center(s,width) + "l" : s := left(s,width) + "r" : s := right(s,width) + default: stop("status_line: Unknown option "||string(p),4) + } + + iputs(igoto(getval("cm"), 1, getval("li")-2)) + emphasize(); writes(s) + normal() + return + +end + + + +procedure message(s) + + # Display prompt s on the second-to-last line of the screen. + # I hate to use the last line, due to all the problems with + # automatic scrolling. + + /s := "" + normal() + iputs(igoto(getval("cm"), 1, getval("li"))) + iputs(getval("ce")) + normal() + iputs(igoto(getval("cm"), 1, getval("li")-1)) + iputs(getval("ce")) + writes(s[1:getval("co")] | s) + return + +end + + + +procedure clear_underline() + + # Horrible way of clearing the screen to all underline mode, but + # the only apparent way we can do it "portably" using the termcap + # capability database. + + local i + + underline() + iputs(igoto(getval("cm"),1,1)) + if getval("am") then { + underline() + 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)) + underline() + writes(repl(" ",getval("co"))) + } + } + iputs(igoto(getval("cm"),1,1)) + +end + + + +procedure clear_emphasize() + + # 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. + + local i + + emphasize() + 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/procs/iterfncs.icn b/ipl/procs/iterfncs.icn new file mode 100644 index 0000000..e60386c --- /dev/null +++ b/ipl/procs/iterfncs.icn @@ -0,0 +1,81 @@ +############################################################################ +# +# File: iterfncs.icn +# +# Subject: Procedures for recursive functions using iteration +# +# Author: Ralph E. Griswold +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures implement commonly referenced ``text-book'' +# recursively defined functions, but using iteration. +# +# acker(i, j) Ackermann's function +# fib(i, j) Generalized Fibonacci (Lucas) sequence +# +############################################################################ +# +# See also: fastfncs.icn, memrfncs.icn, and recrfncs.icn +# +############################################################################ + +procedure acker(i, j) + local k, value, place + + if i = 0 then return j + 1 + + value := list(i + 1) + place := list(i + 1) + + value[1] := 1 + place[1] := 0 + + repeat { # new value[1] + value[1] +:= 1 + place[1] +:= 1 + every k := 1 to i do { # propagate value + if place[k] = 1 then { # initiate new level + value[k + 1] := value[1] + place[k + 1] := 0 + if k ~= i then break next + } + else { + if place[k] = value[k + 1] then { + value[k + 1] := value[1] + place[k + 1] +:= 1 + } + else break next + } + } + if place[i + 1] = j then return value[1] # check for end + } + +end + +procedure fib(i, m) # generalized Fibonacci sequence + local j, n, k + + /m := 0 + + if i = 1 then return 1 + if i = 2 then return m + 1 + + j := 1 + k := m + 1 + + every 1 to i - 2 do { + n := j + k + j := k + k := n + } + + return n + +end diff --git a/ipl/procs/itlib.icn b/ipl/procs/itlib.icn new file mode 100644 index 0000000..e9ed540 --- /dev/null +++ b/ipl/procs/itlib.icn @@ -0,0 +1,481 @@ +############################################################################ +# +# File: itlib.icn +# +# Subject: Procedures for termlib-type tools +# +# Author: Richard L. Goerwitz +# +# Date: March 25, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.33 +# +############################################################################ +# +# The following library represents a series of rough functional +# equivalents to the standard UNIX low-level termcap routines. They +# are not meant as exact termlib clones. Nor are they enhanced to +# take care of magic cookie terminals, terminals that use \D in their +# termcap entries, or, in short, anything I felt would not affect my +# normal, day-to-day work with ANSI and vt100 terminals. There are +# some machines with incomplete or skewed implementations of stty for +# which itlib will not work. See the BUGS section below for work- +# arounds. +# +############################################################################ +# +# setname(term) +# Use only if you wish to initialize itermlib for a terminal +# other than what your current environment specifies. "Term" is the +# name of the termcap entry to use. Normally this initialization is +# done automatically, and need not concern the user. +# +# getval(id) +# Works something like tgetnum, tgetflag, and tgetstr. In the +# spirit of Icon, all three have been collapsed into one routine. +# Integer valued caps are returned as integers, strings as strings, +# and flags as records (if a flag is set, then type(flag) will return +# "true"). Absence of a given capability is signalled by procedure +# failure. +# +# igoto(cm,destcol,destline) - NB: default 1 offset (*not* zero)! +# Analogous to tgoto. "Cm" is the cursor movement command for +# the current terminal, as obtained via getval("cm"). Igoto() +# returns a string which, when output via iputs, will cause the +# cursor to move to column "destcol" and line "destline." Column and +# line are always calculated using a *one* offset. This is far more +# Iconish than the normal zero offset used by tgoto. If you want to +# go to the first square on your screen, then include in your program +# "iputs(igoto(getval("cm"),1,1))." +# +# iputs(cp,affcnt) +# Equivalent to tputs. "Cp" is a string obtained via getval(), +# or, in the case of "cm," via igoto(getval("cm"),x,y). Affcnt is a +# count of affected lines. It is only relevant for terminals which +# specify proportional (starred) delays in their termcap entries. +# +############################################################################ +# +# BUGS: I have not tested these routines much on terminals that +# require padding. These routines WILL NOT WORK if your machine's +# stty command has no -g option (tisk, tisk). This includes 1.0 NeXT +# workstations, and some others that I haven't had time to pinpoint. +# If you are on a BSD box, try typing "sh -c 'stty -g | more'" it may +# be that your stty command is too clever (read stupid) to write its +# output to a pipe. The current workaround is to replace every in- +# stance of /bin/stty with /usr/5bin/stty (or whatever your system +# calls the System V stty command) in this file. If you have no SysV +# stty command online, try replacing "stty -g 2>&1" below with, say, +# "stty -g 2>&1 1> /dev/tty." If you are using mainly modern ter- +# minals that don't need padding, consider using iolib.icn instead of +# itlib.icn. +# +############################################################################ +# +# Requires: UNIX, co-expressions +# +############################################################################ +# +# See also: iscreen.icn, iolib.icn, itlibdos.icn +# +############################################################################ + + +global tc_table, tty_speed +record true() + + +procedure check_features() + + local in_params, line + # global tty_speed + + initial { + find("unix",map(&features)) | + er("check_features","unix system required",1) + find("o-expres",&features) | + er("check_features","co-expressions not implemented - &$#!",1) + system("/bin/stty tabs") | + er("check_features","can't set tabs option",1) + } + + # clumsy, clumsy, clumsy, and probably won't work on all systems + tty_speed := getspeed() + return "term characteristics reset; features check out" + +end + + + +procedure setname(name) + + # Sets current terminal type to "name" and builds a new termcap + # capability database (residing in tc_table). Fails if unable to + # find a termcap entry for terminal type "name." If you want it + # to terminate with an error message under these circumstances, + # comment out "| fail" below, and uncomment the er() line. + + #tc_table is global + + check_features() + + tc_table := table() + tc_table := maketc_table(getentry(name)) | fail + # er("setname","no termcap entry found for "||name,3) + return "successfully reset for terminal " || name + +end + + + +procedure getname() + + # Getname() first checks to be sure we're running under UNIX, and, + # if so, tries to figure out what the current terminal type is, + # checking successively the value of the environment variable + # TERM, and then the output of "tset -". Terminates with an error + # message if the terminal type cannot be ascertained. + + local term, tset_output + + check_features() + + if not (term := getenv("TERM")) then { + tset_output := open("/bin/tset -","pr") | + er("getname","can't find tset command",1) + term := !tset_output + close(tset_output) + } + return \term | + er("getname","can't seem to determine your terminal type",1) + +end + + + +procedure er(func,msg,errnum) + + # short error processing utility + write(&errout,func,": ",msg) + exit(errnum) + +end + + + +procedure getentry(name, termcap_string) + + # "Name" designates the current terminal type. Getentry() scans + # the current environment for the variable TERMCAP. If the + # TERMCAP string represents a termcap entry for a terminal of type + # "name," then getentry() returns the TERMCAP string. Otherwise, + # getentry() will check to see if TERMCAP is a file name. If so, + # getentry() will scan that file for an entry corresponding to + # "name." If the TERMCAP string does not designate a filename, + # getentry() will scan /etc/termcap for the correct entry. + # Whatever the input file, if an entry for terminal "name" is + # found, getentry() returns that entry. Otherwise, getentry() + # fails. + + local f, getline, line, nm, ent1, ent2, entry + + # You can force getentry() to use a specific termcap file by cal- + # ling it with a second argument - the name of the termcap file + # to use instead of the regular one, or the one specified in the + # termcap environment variable. + /termcap_string := getenv("TERMCAP") + + if \termcap_string ? (not match("/"), pos(1) | tab(find("|")+1), =name) + then { + # if entry ends in tc= then add in the named tc entry + termcap_string ?:= tab(find("tc=")) || + # Recursively fetch the new termcap entry w/ name trimmed. + (move(3), getentry(tab(find(":")), "/etc/termcap") ? + (tab(find(":")+1), tab(0))) + return termcap_string + } + else { + + # The logic here probably isn't clear. The idea is to try to use + # the termcap environment variable successively as 1) a termcap en- + # try and then 2) as a termcap file. If neither works, 3) go to + # the /etc/termcap file. The else clause here does 2 and, if ne- + # cessary, 3. The "\termcap_string ? (not match..." expression + # handles 1. + + if find("/",\termcap_string) + then f := open(termcap_string) + /f := open("/etc/termcap") | + er("getentry","I can't access your /etc/termcap file",1) + + getline := create read_file(f) + + while line := @getline do { + if line ? (pos(1) | tab(find("|")+1), =name, any(':|')) then { + entry := "" + while (\line | @getline) ? { + if entry ||:= 1(tab(find(":")+1), pos(0)) + then { + close(f) + # if entry ends in tc= then add in the named tc entry + entry ?:= tab(find("tc=")) || + # recursively fetch the new termcap entry + (move(3), getentry(tab(find(":"))) ? + # remove the name field from the new entry + (tab(find(":")+1), tab(0))) + return entry + } + else { + \line := &null # must precede the next line + entry ||:= trim(trim(tab(0),'\\'),':') + } + } + } + } + } + + close(f) + er("getentry","can't find and/or process your termcap entry",3) + +end + + + +procedure read_file(f) + + # Suspends all non #-initial lines in the file f. + # Removes leading tabs and spaces from lines before suspending + # them. + + local line + + \f | er("read_tcap_file","no valid termcap file found",3) + while line := read(f) do { + match("#",line) & next + line ?:= (tab(many('\t ')) | &null, tab(0)) + suspend line + } + + fail + +end + + + +procedure maketc_table(entry) + + # Maketc_table(s) (where s is a valid termcap entry for some + # terminal-type): Returns a table in which the keys are termcap + # capability designators, and the values are the entries in + # "entry" for those designators. + + local k, v, decoded_value + + /entry & er("maketc_table","no entry given",8) + if entry[-1] ~== ":" then entry ||:= ":" + + /tc_table := table() + + entry ? { + + tab(find(":")+1) # tab past initial (name) field + + while tab((find(":")+1) \ 1) ? { + &subject == "" & next + if k := 1(move(2), ="=") + then decoded_value := Decode(tab(find(":"))) + else if k := 1(move(2), ="#") + then decoded_value := integer(tab(find(":"))) + else if k := 1(tab(find(":")), pos(-1)) + then decoded_value := true() + else er("maketc_table", "your termcap file has a bad entry",3) + /tc_table[k] := decoded_value + &null + } + } + + return tc_table + +end + + + +procedure getval(id) + + /tc_table := maketc_table(getentry(getname())) | + er("getval","can't make a table for your terminal",4) + + return \tc_table[id] | fail + # er("getval","the current terminal doesn't support "||id,7) + +end + + + +procedure Decode(s) + local new_s, chr, chr2 + + # Does things like turn ^ plus a letter into a genuine control + # character. + + new_s := "" + + s ? { + + while new_s ||:= tab(upto('\\^')) do { + chr := move(1) + if chr == "\\" then { + new_s ||:= { + case chr2 := move(1) of { + "\\" : "\\" + "^" : "^" + "E" : "\e" + "b" : "\b" + "f" : "\f" + "n" : "\n" + "r" : "\r" + "t" : "\t" + default : { + if any(&digits,chr2) then { + char(integer("8r"||chr2||move(2 to 0 by -1))) | + er("Decode","bad termcap entry",3) + } + else chr2 + } + } + } + } + else new_s ||:= char(ord(map(move(1),&lcase,&ucase)) - 64) + } + new_s ||:= tab(0) + } + + return new_s + +end + + + +procedure igoto(cm,col,line) + + local colline, range, increment, padding, str, outstr, chr, x, y + + if \col > (tc_table["co"]) | \line > (tc_table["li"]) then { + colline := string(\col) || "," || string(\line) | string(\col|line) + range := "(" || tc_table["co"]-1 || "," || tc_table["li"]-1 || ")" + er("igoto",colline || " out of range " || (\range|""),9) + } + + # Use the Iconish 1;1 upper left corner & not the C-ish 0 offsets + increment := -1 + outstr := "" + + cm ? { + while outstr ||:= tab(find("%")) do { + tab(match("%")) + if padding := integer(tab(any('23'))) + then chr := (="d" | "d") + else chr := move(1) + if case \chr of { + "." : outstr ||:= char(line + increment) + "+" : outstr ||:= char(line + ord(move(1)) + increment) + "d" : { + str := string(line + increment) + outstr ||:= right(str, \padding, "0") | str + } + } + then line :=: col + else { + case chr of { + "n" : line := ixor(line,96) & col := ixor(col,96) + "i" : increment := 0 + "r" : line :=: col + "%" : outstr ||:= "%" + "B" : line := ior(ishift(line / 10, 4), line % 10) + ">" : { + x := move(1); y := move(1) + line > ord(x) & line +:= ord(y) + &null + } + } | er("goto","bad termcap entry",5) + } + } + return outstr || tab(0) + } + +end + + + +procedure iputs(cp, affcnt) + + local baud_rates, char_rates, i, delay, PC, minimum_padding_speed, char_time + + static num_chars, char_times + # global tty_speed + + initial { + num_chars := &digits ++ '.' + char_times := table() + # Baud rates in decimal, not octal (as in termio.h) + baud_rates := [0,7,8,9,10,11,12,13,14,15,16] + char_rates := [0,333,166,83,55,41,20,10,10,10,10] + every i := 1 to *baud_rates do { + char_times[baud_rates[i]] := char_rates[i] + } + } + + type(cp) == "string" | + er("iputs","you can't iputs() a non-string value!",10) + + cp ? { + delay := tab(many(num_chars)) + if ="*" then { + delay *:= \affcnt | + er("iputs","affected line count missing",6) + } + writes(tab(0)) + } + + if (\delay, tty_speed ~= 0) then { + minimum_padding_speed := getval("pb") + if /minimum_padding_speed | tty_speed >= minimum_padding_speed then { + PC := tc_table["pc"] | "\000" + char_time := char_times[tty_speed] | (return "speed error") + delay := (delay * char_time) + (char_time / 2) + every 1 to delay by 10 + do writes(PC) + } + } + + return + +end + + + +procedure getspeed() + + local stty_g, stty_output, c_cflag, o_speed + + stty_g := open("/bin/stty -g 2>&1","pr") | + er("getspeed","Can't access your stty command.",4) + stty_output := !stty_g + close(stty_g) + + \stty_output ? { + # tab to the third field of the output of the stty -g cmd + tab(find(":")+1) & tab(find(":")+1) & + c_cflag := integer("16r"||tab(find(":"))) + } | er("getspeed","Unable to unwind your stty -g output.",4) + + o_speed := iand(15,c_cflag) + return o_speed + +end diff --git a/ipl/procs/itlibdos.icn b/ipl/procs/itlibdos.icn new file mode 100644 index 0000000..f17e31f --- /dev/null +++ b/ipl/procs/itlibdos.icn @@ -0,0 +1,480 @@ +############################################################################ +# +# File: itlibdos.icn +# +# Subject: Procedures for MS-DOS termlib-type tools +# +# Author: Richard L. Goerwitz +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.15 +# +############################################################################ +# +# The following library represents a series of rough functional +# equivalents to the standard UNIX low-level termcap routines. They +# are not meant as exact termlib clones. Nor are they enhanced to +# take care of magic cookie terminals, terminals that use \D in their +# termcap entries, or, in short, anything I felt would not affect my +# normal, day-to-day work with ANSI and vt100 terminals. At this +# point I'd recommend trying iolib.icn instead of itlibdos.icn. Iolib +# is largely DOS-UNIX interchangeable, and it does pretty much every- +# thing itlibdos.icn does. +# +############################################################################ +# +# Requires: An MS-DOS platform & co-expressions. The MS-DOS version +# is a port of the UNIX version. Software you write for this library +# can be made to run under UNIX simply by substituting the UNIX ver- +# sion of this library. See below for additional notes on how to use +# this MS-DOS port. +# +# setname(term) +# Use only if you wish to initialize itermlib for a terminal +# other than what your current environment specifies. "Term" is the +# name of the termcap entry to use. Normally this initialization is +# done automatically, and need not concern the user. +# +# getval(id) +# Works something like tgetnum, tgetflag, and tgetstr. In the +# spirit of Icon, all three have been collapsed into one routine. +# Integer valued caps are returned as integers, strings as strings, +# and flags as records (if a flag is set, then type(flag) will return +# "true"). Absence of a given capability is signalled by procedure +# failure. +# +# igoto(cm,destcol,destline) - NB: default 1 offset (*not* zero)! +# Analogous to tgoto. "Cm" is the cursor movement command for +# the current terminal, as obtained via getval("cm"). Igoto() +# returns a string which, when output via iputs, will cause the +# cursor to move to column "destcol" and line "destline." Column and +# line are always calculated using a *one* offset. This is far more +# Iconish than the normal zero offset used by tgoto. If you want to +# go to the first square on your screen, then include in your program +# "iputs(igoto(getval("cm"),1,1))." +# +# iputs(cp,affcnt) +# Equivalent to tputs. "Cp" is a string obtained via getval(), +# or, in the case of "cm," via igoto(getval("cm"),x,y). Affcnt is a +# count of affected lines. It is only relevant for terminals which +# specify proportional (starred) delays in their termcap entries. +# +############################################################################ +# +# Notes on the MS-DOS version: +# There are two basic reasons for using the I/O routines +# contained in this package. First, by using a set of generalized +# routines, your code will become much more readable. Secondly, by +# using a high level interface, you can avoid the cardinal +# programming error of hard coding things like screen length and +# escape codes into your programs. +# To use this collection of programs, you must do two things. +# First, you must add the line "device=ansi.sys" (or the name of some +# other driver, like zansi.sys, nansi.sys, or nnansi.sys [=new +# nansi.sys]) to your config.sys file. Secondly, you must add two +# lines to your autoexec.bat file: 1) "set TERM=ansi-mono" and 2) +# "set TERMCAP=\location\termcap." The purpose of setting the TERM +# variable is to tell this program what driver you are using. If you +# have a color system, use "ansi-color" instead of "ansi-mono," and +# if you are using nansi or zansi instead of vanilla ansi, use one of +# these names instead of the "ansi" (e.g. "zansi-mono"). The purpose +# of setting TERMCAP is to make it possible to determine where the +# termcap file is located. The termcap file (which should have been +# packed with this library as termcap.dos) is a short database of all +# the escape sequences used by the various terminal drivers. Set +# TERMCAP so that it reflects the location of this file (which should +# be renamed as termcap, for the sake of consistency with the UNIX +# version). Naturally, you must change "\location\" above to reflect +# the correct path on your system. With some distributions, a second +# termcap file may be included (termcap2.dos). Certain games work a +# lot better using this alternate file. To try it out, rename it to +# termcap, and set TERMCAP to its location. +# Although I make no pretense here of providing here a complete +# introduction to the format of the termcap database file, it will be +# useful, I think, to explain a few basic facts about how to use this +# program in conjunction with it. If, say, you want to clear the +# screen, add the line, +# +# iputs(getval("cl")) +# +# to your program. The function iputs() outputs screen control +# sequences. Getval retrieves a specific sequence from the termcap +# file. The string "cl" is the symbol used in the termcap file to +# mark the code used to clear the screen. By executing the +# expression "iputs(getval("cl"))," you are 1) looking up the "cl" +# (clear) code in the termcap database entry for your terminal, and +# the 2) outputting that sequence to the screen. +# Some other useful termcap symbols are "ce" (clear to end of +# line), "ho" (go to the top left square on the screen), "so" (begin +# standout mode), and "se" (end standout mode). To output a +# boldfaced string, str, to the screen, you would write - +# +# iputs(getval("so")) +# writes(str) +# iputs(getval("se")) +# +# You could write "writes(getval("so") || str || getval("se")), but +# this would only work for DOS. Some UNIX terminals require padding, +# and iputs() handles them specially. Normally you should not worry +# about UNIX quirks under DOS. It is in general wise, though, to +# separate out screen control sequences, and output them via iputs(). +# It is also heartily to be recommended that MS-DOS programmers +# try not to assume that everyone will be using a 25-line screen. +# Some terminals are 24-line. Some 43. Some have variable window +# sizes. If you want to put a status line on, say, the 2nd-to-last +# line of the screen, then determine what that line is by executing +# "getval("li")." The termcap database holds not only string-valued +# sequences, but numeric ones as well. The value of "li" tells you +# how many lines the terminal has (compare "co," which will tell you +# how many columns). To go to the beginning of the second-to-last +# line on the screen, type in: +# +# iputs(igoto(getval("cm"), 1, getval("li")-1)) +# +# The "cm" capability is a special capability, and needs to be output +# via igoto(cm,x,y), where cm is the sequence telling your computer +# to move the cursor to a specified spot, x is the column, and y is +# the row. The expression "getval("li")-1" will return the number of +# the second-to-last line on your screen. +# +############################################################################ +# +# Requires: MS-DOS, coexpressions +# +############################################################################ +# +# See also: iscreen.icn, iolib.icn, itlib.icn +# +############################################################################ + + +global tc_table +record true() + + +procedure check_features() + + local in_params, line + + initial { + find("ms-dos",map(&features)) | + er("check_features","MS-DOS system required",1) + find("o-expres",&features) | + er("check_features","co-expressions not implemented - &$#!",1) + } + + return + +end + + + +procedure setname(name) + + # Sets current terminal type to "name" and builds a new termcap + # capability database (residing in tc_table). Fails if unable to + # find a termcap entry for terminal type "name." If you want it + # to terminate with an error message under these circumstances, + # comment out "| fail" below, and uncomment the er() line. + + #tc_table is global + + check_features() + + tc_table := maketc_table(getentry(name)) | fail + # er("setname","no termcap entry found for "||name,3) + return + +end + + + +procedure getname() + + # Getname() first checks to be sure we're running under DOS, and, + # if so, tries to figure out what the current terminal type is, + # checking the value of the environment variable TERM, and if this + # is unsuccessful, defaulting to "mono." + + local term, tset_output + + check_features() + term := getenv("TERM") | "mono" + + return \term | + er("getname","can't seem to determine your terminal type",1) + +end + + + +procedure er(func,msg,errnum) + + # short error processing utility + write(&errout,func,": ",msg) + exit(errnum) + +end + + + +procedure getentry(name, termcap_string) + + # "Name" designates the current terminal type. Getentry() scans + # the current environment for the variable TERMCAP. If the + # TERMCAP string represents a termcap entry for a terminal of type + # "name," then getentry() returns the TERMCAP string. Otherwise, + # getentry() will check to see if TERMCAP is a file name. If so, + # getentry() will scan that file for an entry corresponding to + # "name." If the TERMCAP string does not designate a filename, + # getentry() will look through ./termcap for the correct entry. + # Whatever the input file, if an entry for terminal "name" is + # found, getentry() returns that entry. Otherwise, getentry() + # fails. + + local f, getline, line, nm, ent1, ent2, entry + + /termcap_string := getenv("TERMCAP") + + if \termcap_string ? (not match("\\"), pos(1) | tab(find("|")+1), =name) + then return termcap_string + else { + + # The logic here probably isn't clear. The idea is to try to use + # the termcap environment variable successively as 1) a termcap en- + # try and then 2) as a termcap file. If neither works, 3) go to + # the ./termcap file. The else clause here does 2 and, if ne- + # cessary, 3. The "\termcap_string ? (not match..." expression + # handles 1. + + if find("\\",\termcap_string) + then f := open(termcap_string) + /f := open("termcap") | + er("getentry","I can't access your termcap file",1) + + getline := create read_file(f) + + while line := @getline do { + if line ? (pos(1) | tab(find("|")+1), =name, any(':|')) then { + entry := "" + while (\line | @getline) ? { + if entry ||:= 1(tab(find(":")+1), pos(0)) + then { + close(f) + # if entry ends in tc= then add in the named tc entry + entry ?:= tab(find("tc=")) || + # recursively fetch the new termcap entry + (move(3), getentry(tab(find(":"))) ? + # remove the name field from the new entry + (tab(find(":")+1), tab(0))) + return entry + } + else { + \line := &null # must precede the next line + entry ||:= trim(trim(tab(0),'\\'),':') + } + } + } + } + } + + close(f) + er("getentry","can't find and/or process your termcap entry",3) + +end + + + +procedure read_file(f) + + # Suspends all non #-initial lines in the file f. + # Removes leading tabs and spaces from lines before suspending + # them. + + local line + + \f | er("read_tcap_file","no valid termcap file found",3) + while line := read(f) do { + match("#",line) & next + line ?:= (tab(many('\t ')) | &null, tab(0)) + suspend line + } + + fail + +end + + + +procedure maketc_table(entry) + + # Maketc_table(s) (where s is a valid termcap entry for some + # terminal-type): Returns a table in which the keys are termcap + # capability designators, and the values are the entries in + # "entry" for those designators. + + local k, v + + /entry & er("maketc_table","no entry given",8) + if entry[-1] ~== ":" then entry ||:= ":" + + tc_table := table() + + entry ? { + + tab(find(":")+1) # tab past initial (name) field + + while tab((find(":")+1) \ 1) ? { + + &subject == "" & next + if k := 1(move(2), ="=") + then tc_table[k] := Decode(tab(find(":"))) + else if k := 1(move(2), ="#") + then tc_table[k] := integer(tab(find(":"))) + else if k := 1(tab(find(":")), pos(-1)) + then tc_table[k] := true() + else er("maketc_table", "your termcap file has a bad entry",3) + } + } + + return tc_table + +end + + + +procedure getval(id) + + /tc_table := maketc_table(getentry(getname())) | + er("getval","can't make a table for your terminal",4) + + return \tc_table[id] | fail + # er("getval","the current terminal doesn't support "||id,7) + +end + + + +procedure Decode(s) + local new_s, chr, chr2 + + # Does things like turn ^ plus a letter into a genuine control + # character. + + new_s := "" + + s ? { + while new_s ||:= tab(upto('\\^')) do { + chr := move(1) + if chr == "\\" then { + new_s ||:= { + case chr2 := move(1) of { + "\\" : "\\" + "^" : "^" + "E" : "\e" + "b" : "\b" + "f" : "\f" + "n" : "\n" + "r" : "\r" + "t" : "\t" + default : { + if any(&digits,chr2) then { + char(integer("8r"||chr2||move(2 to 0 by -1))) | + er("Decode","bad termcap entry",3) + } + else chr2 + } + } + } + } + else new_s ||:= char(ord(map(move(1),&lcase,&ucase)) - 64) + } + new_s ||:= tab(0) + } + + return new_s + +end + + + +procedure igoto(cm,col,line) + + local colline, range, increment, padding, str, outstr, chr, x, y + + if col > (tc_table["co"]) | line > (tc_table["li"]) then { + colline := string(\col) || "," || string(\line) | string(\col|line) + range := "(" || tc_table["co"]-1 || "," || tc_table["li"]-1 || ")" + er("igoto",colline || " out of range " || (\range|""),9) + } + + # Use the Iconish 1;1 upper left corner & not the C-ish 0 offsets + increment := -1 + outstr := "" + + cm ? { + while outstr ||:= tab(find("%")) do { + tab(match("%")) + if padding := integer(tab(any('23'))) + then chr := (="d" | "d") + else chr := move(1) + if case \chr of { + "." : outstr ||:= char(line + increment) + "+" : outstr ||:= char(line + ord(move(1)) + increment) + "d" : { + str := string(line + increment) + outstr ||:= right(str, \padding, "0") | str + } + } + then line :=: col + else { + case chr of { + "n" : line := ixor(line,96) & col := ixor(col,96) + "i" : increment := 0 + "r" : line :=: col + "%" : outstr ||:= "%" + "B" : line := ior(ishift(line / 10, 4), line % 10) + ">" : { + x := move(1); y := move(1) + line > ord(x) & line +:= ord(y) + &null + } + } | er("goto","bad termcap entry",5) + } + } + return outstr || tab(0) + } + +end + + + +procedure iputs(cp, affcnt) + + # Writes cp to the screen. Use this instead of writes() for + # compatibility with the UNIX version (which will need to send + # null padding in some cases). Iputs() also does a useful type + # check. + + static num_chars + initial num_chars := &digits ++ '.' + + type(cp) == "string" | + er("iputs","you can't iputs() a non-string value!",10) + + cp ? { + if tab(many(num_chars)) & ="*" then + stop("iputs: MS-DOS termcap files shouldn't specify padding.") + writes(tab(0)) + } + + return + +end diff --git a/ipl/procs/itokens.icn b/ipl/procs/itokens.icn new file mode 100644 index 0000000..656292d --- /dev/null +++ b/ipl/procs/itokens.icn @@ -0,0 +1,934 @@ +############################################################################ +# +# File: itokens.icn +# +# Subject: Procedures for tokenizing Icon code +# +# Author: Richard L. Goerwitz +# +# Date: March 3, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.11 +# +############################################################################ +# +# This file contains itokens() - a utility for breaking Icon source +# files up into individual tokens. This is the sort of routine one +# needs to have around when implementing things like pretty printers, +# preprocessors, code obfuscators, etc. It would also be useful for +# implementing cut-down implementations of Icon written in Icon - the +# sort of thing one might use in an interactive tutorial. +# +# Itokens(f, x) takes, as its first argument, f, an open file, and +# suspends successive TOK records. TOK records contain two fields. +# The first field, sym, contains a string that represents the name of +# the next token (e.g. "CSET", "STRING", etc.). The second field, +# str, gives that token's literal value. E.g. the TOK for a literal +# semicolon is TOK("SEMICOL", ";"). For a mandatory newline, itokens +# would suspend TOK("SEMICOL", "\n"). +# +# Unlike Icon's own tokenizer, itokens() does not return an EOFX +# token on end-of-file, but rather simply fails. It also can be +# instructed to return syntactically meaningless newlines by passing +# it a nonnull second argument (e.g. itokens(infile, 1)). These +# meaningless newlines are returned as TOK records with a null sym +# field (i.e. TOK(&null, "\n")). +# +# NOTE WELL: If new reserved words or operators are added to a given +# implementation, the tables below will have to be altered. Note +# also that &keywords should be implemented on the syntactic level - +# not on the lexical one. As a result, a keyword like &features will +# be suspended as TOK("CONJUNC", "&") and TOK("IDENT", "features"). +# +############################################################################ +# +# Links: scan +# +############################################################################ +# +# Requires: coexpressions +# +############################################################################ + +link scan + +global next_c, line_number +record TOK(sym, str) + +# +# main: an Icon source code uglifier +# +# Stub main for testing; uncomment & compile. The resulting +# executable will act as an Icon file compressor, taking the +# standard input and outputting Icon code stripped of all +# unnecessary whitespace. Guaranteed to make the code a visual +# mess :-). +# +#procedure main() +# +# local separator, T +# separator := "" +# every T := itokens(&input) do { +# if any(&digits ++ &letters ++ '_.', \T.str, 1, 2) & \T.sym ~== "DOT" +# then writes(separator) +# if T.sym == "SEMICOL" then writes(";") else writes(T.str) +# if any(&digits ++ &letters ++ '_.', \T.str, -1, 0) & \T.sym ~== "DOT" +# then separator := " " else separator := "" +# } +# +#end + + +# +# itokens: file x anything -> TOK records (a generator) +# (stream, nostrip) -> Rs +# +# Where stream is an open file, anything is any object (it only +# matters whether it is null or not), and Rs are TOK records. +# Note that itokens strips out useless newlines. If the second +# argument is nonnull, itokens does not strip out superfluous +# newlines. It may be useful to keep them when the original line +# structure of the input file must be maintained. +# +procedure itokens(stream, nostrip) + + local T, last_token + + # initialize to some meaningless value + last_token := TOK() + + every T := \iparse_tokens(stream) do { + if \T.sym then { + if T.sym == "EOFX" then fail + else { + # + # If the last token was a semicolon, then interpret + # all ambiguously unary/binary sequences like "**" as + # beginners (** could be two unary stars or the [c]set + # intersection operator). + # + if \last_token.sym == "SEMICOL" + then suspend last_token := expand_fake_beginner(T) + else suspend last_token := T + } + } else { + if \nostrip + then suspend last_token := T + } + } + +end + + +# +# expand_fake_beginner: TOK record -> TOK records +# +# Some "beginner" tokens aren't really beginners. They are token +# sequences that could be either a single binary operator or a +# series of unary operators. The tokenizer's job is just to snap +# up as many characters as could logically constitute an operator. +# Here is where we decide whether to break the sequence up into +# more than one op or not. +# +procedure expand_fake_beginner(next_token) + + static exptbl + initial { + exptbl := table() + insert(exptbl, "CONCAT", [TOK("BAR", "|"), TOK("BAR", "|")]) + insert(exptbl, "DIFF", [TOK("MINUS", "-"), TOK("MINUS", "-")]) + insert(exptbl, "EQUIV", [TOK("NUMEQ", "="), TOK("NUMEQ", "="), + TOK("NUMEQ", "=")]) + insert(exptbl, "INTER", [TOK("STAR", "*"), TOK("STAR", "*")]) + insert(exptbl, "LCONCAT", [TOK("BAR", "|"), TOK("BAR", "|"), + TOK("BAR", "|")]) + insert(exptbl, "LEXEQ", [TOK("NUMEQ", "="), TOK("NUMEQ", "=")]) + insert(exptbl, "LEXNE", [TOK("TILDE", "~"), TOK("NUMEQ", "="), + TOK("NUMEQ", "=")]) + insert(exptbl, "NOTEQUIV",[TOK("TILDE", "~"), TOK("NUMEQ","="), + TOK("NUMEQ", "="), TOK("NUMEQ", "=")]) + insert(exptbl, "NUMNE", [TOK("TILDE", "~"), TOK("NUMEQ","=")]) + insert(exptbl, "UNION", [TOK("PLUS", "+"), TOK("PLUS", "+")]) + } + + if \exptbl[next_token.sym] + then suspend !exptbl[next_token.sym] + else return next_token + +end + + +# +# iparse_tokens: file -> TOK records (a generator) +# (stream) -> tokens +# +# Where file is an open input stream, and tokens are TOK records +# holding both the token type and actual token text. +# +# TOK records contain two parts, a preterminal symbol (the first +# "sym" field), and the actual text of the token ("str"). The +# parser only pays attention to the sym field, although the +# strings themselves get pushed onto the value stack. +# +# Note the following kludge: Unlike real Icon tokenizers, this +# procedure returns syntactially meaningless newlines as TOK +# records with a null sym field. Normally they would be ignored. +# I wanted to return them so they could be printed on the output +# stream, thus preserving the line structure of the original +# file, and making later diagnostic messages more usable. +# +procedure iparse_tokens(stream, getchar) + + local elem, whitespace, token, last_token, primitives, reserveds + static be_tbl, reserved_tbl, operators + initial { + + # Primitive Tokens + # + primitives := [ + ["identifier", "IDENT", "be"], + ["integer-literal", "INTLIT", "be"], + ["real-literal", "REALLIT", "be"], + ["string-literal", "STRINGLIT", "be"], + ["cset-literal", "CSETLIT", "be"], + ["end-of-file", "EOFX", "" ]] + + # Reserved Words + # + reserveds := [ + ["break", "BREAK", "be"], + ["by", "BY", "" ], + ["case", "CASE", "b" ], + ["create", "CREATE", "b" ], + ["default", "DEFAULT", "b" ], + ["do", "DO", "" ], + ["else", "ELSE", "" ], + ["end", "END", "b" ], + ["every", "EVERY", "b" ], + ["fail", "FAIL", "be"], + ["global", "GLOBAL", "" ], + ["if", "IF", "b" ], + ["initial", "INITIAL", "b" ], + ["invocable", "INVOCABLE", "" ], + ["link", "LINK", "" ], + ["local", "LOCAL", "b" ], + ["next", "NEXT", "be"], + ["not", "NOT", "b" ], + ["of", "OF", "" ], + ["procedure", "PROCEDURE", "" ], + ["record", "RECORD", "" ], + ["repeat", "REPEAT", "b" ], + ["return", "RETURN", "be"], + ["static", "STATIC", "b" ], + ["suspend", "SUSPEND", "be"], + ["then", "THEN", "" ], + ["to", "TO", "" ], + ["until", "UNTIL", "b" ], + ["while", "WHILE", "b" ]] + + # Operators + # + operators := [ + [":=", "ASSIGN", "" ], + ["@", "AT", "b" ], + ["@:=", "AUGACT", "" ], + ["&:=", "AUGAND", "" ], + ["=:=", "AUGEQ", "" ], + ["===:=", "AUGEQV", "" ], + [">=:=", "AUGGE", "" ], + [">:=", "AUGGT", "" ], + ["<=:=", "AUGLE", "" ], + ["<:=", "AUGLT", "" ], + ["~=:=", "AUGNE", "" ], + ["~===:=", "AUGNEQV", "" ], + ["==:=", "AUGSEQ", "" ], + [">>=:=", "AUGSGE", "" ], + [">>:=", "AUGSGT", "" ], + ["<<=:=", "AUGSLE", "" ], + ["<<:=", "AUGSLT", "" ], + ["~==:=", "AUGSNE", "" ], + ["\\", "BACKSLASH", "b" ], + ["!", "BANG", "b" ], + ["|", "BAR", "b" ], + ["^", "CARET", "b" ], + ["^:=", "CARETASGN", "b" ], + [":", "COLON", "" ], + [",", "COMMA", "" ], + ["||", "CONCAT", "b" ], + ["||:=", "CONCATASGN","" ], + ["&", "CONJUNC", "b" ], + [".", "DOT", "b" ], + ["--", "DIFF", "b" ], + ["--:=", "DIFFASGN", "" ], + ["===", "EQUIV", "b" ], + ["**", "INTER", "b" ], + ["**:=", "INTERASGN", "" ], + ["{", "LBRACE", "b" ], + ["[", "LBRACK", "b" ], + ["|||", "LCONCAT", "b" ], + ["|||:=", "LCONCATASGN","" ], + ["==", "LEXEQ", "b" ], + [">>=", "LEXGE", "" ], + [">>", "LEXGT", "" ], + ["<<=", "LEXLE", "" ], + ["<<", "LEXLT", "" ], + ["~==", "LEXNE", "b" ], + ["(", "LPAREN", "b" ], + ["-:", "MCOLON", "" ], + ["-", "MINUS", "b" ], + ["-:=", "MINUSASGN", "" ], + ["%", "MOD", "" ], + ["%:=", "MODASGN", "" ], + ["~===", "NOTEQUIV", "b" ], + ["=", "NUMEQ", "b" ], + [">=", "NUMGE", "" ], + [">", "NUMGT", "" ], + ["<=", "NUMLE", "" ], + ["<", "NUMLT", "" ], + ["~=", "NUMNE", "b" ], + ["+:", "PCOLON", "" ], + ["+", "PLUS", "b" ], + ["+:=", "PLUSASGN", "" ], + ["?", "QMARK", "b" ], + ["<-", "REVASSIGN", "" ], + ["<->", "REVSWAP", "" ], + ["}", "RBRACE", "e" ], + ["]", "RBRACK", "e" ], + [")", "RPAREN", "e" ], + [";", "SEMICOL", "" ], + ["?:=", "SCANASGN", "" ], + ["/", "SLASH", "b" ], + ["/:=", "SLASHASGN", "" ], + ["*", "STAR", "b" ], + ["*:=", "STARASGN", "" ], + [":=:", "SWAP", "" ], + ["~", "TILDE", "b" ], + ["++", "UNION", "b" ], + ["++:=", "UNIONASGN", "" ], + ["$(", "LBRACE", "b" ], + ["$)", "RBRACE", "e" ], + ["$<", "LBRACK", "b" ], + ["$>", "RBRACK", "e" ], + ["$", "RHSARG", "b" ], + ["%$(", "BEGGLOB", "b" ], + ["%$)", "ENDGLOB", "e" ], + ["%{", "BEGGLOB", "b" ], + ["%}", "ENDGLOB", "e" ], + ["%%", "NEWSECT", "be"]] + + # static be_tbl, reserved_tbl + reserved_tbl := table() + every elem := !reserveds do + insert(reserved_tbl, elem[1], elem[2]) + be_tbl := table() + every elem := !primitives | !reserveds | !operators do { + insert(be_tbl, elem[2], elem[3]) + } + } + + /getchar := create { + line_number := 0 + ! ( 1(!stream, line_number +:=1) || "\n" ) + } + whitespace := ' \t' + /next_c := @getchar | { + if \stream then + return TOK("EOFX") + else fail + } + + repeat { + case next_c of { + + "." : { + # Could be a real literal *or* a dot operator. Check + # following character to see if it's a digit. If so, + # it's a real literal. We can only get away with + # doing the dot here because it is not a substring of + # any longer identifier. If this gets changed, we'll + # have to move this code into do_operator(). + # + last_token := do_dot(getchar) + suspend last_token +# write(&errout, "next_c == ", image(next_c)) + next + } + + "\n" : { + # If do_newline fails, it means we're at the end of + # the input stream, and we should break out of the + # repeat loop. + # + every last_token := do_newline(getchar, last_token, be_tbl) + do suspend last_token + if next_c === &null then break + next + } + + "\#" : { + # Just a comment. Strip it by reading every character + # up to the next newline. The global var next_c + # should *always* == "\n" when this is done. + # + do_number_sign(getchar) +# write(&errout, "next_c == ", image(next_c)) + next + } + + "\"" : { + # Suspend as STRINGLIT everything from here up to the + # next non-backslashed quotation mark, inclusive + # (accounting for the _ line-continuation convention). + # + last_token := do_quotation_mark(getchar) + suspend last_token +# write(&errout, "next_c == ", image(next_c)) + next + } + + "'" : { + # Suspend as CSETLIT everything from here up to the + # next non-backslashed apostrophe, inclusive. + # + last_token := do_apostrophe(getchar) + suspend last_token +# write(&errout, "next_c == ", image(next_c)) + next + } + + &null : stop("iparse_tokens (lexer): unexpected EOF") + + default : { + # If we get to here, we have either whitespace, an + # integer or real literal, an identifier or reserved + # word (both get handled by do_identifier), or an + # operator. The question of which we have can be + # determined by checking the first character. + # + if any(whitespace, next_c) then { + # Like all of the TOK forming procedures, + # do_whitespace resets next_c. + do_whitespace(getchar, whitespace) + # don't suspend any tokens + next + } + if any(&digits, next_c) then { + last_token := do_digits(getchar) + suspend last_token + next + } + if any(&letters ++ '_', next_c) then { + last_token := do_identifier(getchar, reserved_tbl) + suspend last_token + next + } +# write(&errout, "it's an operator") + last_token := do_operator(getchar, operators) + suspend last_token + next + } + } + } + + # If stream argument is nonnull, then we are in the top-level + # iparse_tokens(). If not, then we are in a recursive call, and + # we should not emit all this end-of-file crap. + # + if \stream then { + return TOK("EOFX") + } + else fail + +end + + +# +# do_dot: coexpression -> TOK record +# getchar -> t +# +# Where getchar is the coexpression that produces the next +# character from the input stream and t is a token record whose +# sym field contains either "REALLIT" or "DOT". Essentially, +# do_dot checks the next char on the input stream to see if it's +# an integer. Since the preceding char was a dot, an integer +# tips us off that we have a real literal. Otherwise, it's just +# a dot operator. Note that do_dot resets next_c for the next +# cycle through the main case loop in the calling procedure. +# +procedure do_dot(getchar) + + local token + # global next_c + +# write(&errout, "it's a dot") + + # If dot's followed by a digit, then we have a real literal. + # + if any(&digits, next_c := @getchar) then { +# write(&errout, "dot -> it's a real literal") + token := "." || next_c + while any(&digits, next_c := @getchar) do + token ||:= next_c + if token ||:= (next_c == ("e"|"E")) then { + while (next_c := @getchar) == "0" + while any(&digits, next_c) do { + token ||:= next_c + next_c = @getchar + } + } + return TOK("REALLIT", token) + } + + # Dot not followed by an integer; so we just have a dot operator, + # and not a real literal. + # +# write(&errout, "dot -> just a plain dot") + return TOK("DOT", ".") + +end + + +# +# do_newline: coexpression x TOK record x table -> TOK records +# (getchar, last_token, be_tbl) -> Ts (a generator) +# +# Where getchar is the coexpression that returns the next +# character from the input stream, last_token is the last TOK +# record suspended by the calling procedure, be_tbl is a table of +# tokens and their "beginner/ender" status, and Ts are TOK +# records. Note that do_newline resets next_c. Do_newline is a +# mess. What it does is check the last token suspended by the +# calling procedure to see if it was a beginner or ender. It +# then gets the next token by calling iparse_tokens again. If +# the next token is a beginner and the last token is an ender, +# then we have to suspend a SEMICOL token. In either event, both +# the last and next token are suspended. +# +procedure do_newline(getchar, last_token, be_tbl) + + local next_token + # global next_c + +# write(&errout, "it's a newline") + + # Go past any additional newlines. + # + while next_c == "\n" do { + # NL can be the last char in the getchar stream; if it *is*, + # then signal that it's time to break out of the repeat loop + # in the calling procedure. + # + next_c := @getchar | { + next_c := &null + fail + } + suspend TOK(&null, next_c == "\n") + } + + # If there was a last token (i.e. if a newline wasn't the first + # character of significance in the input stream), then check to + # see if it was an ender. If so, then check to see if the next + # token is a beginner. If so, then suspend a TOK("SEMICOL") + # record before suspending the next token. + # + if find("e", be_tbl[(\last_token).sym]) then { +# write(&errout, "calling iparse_tokens via do_newline") +# &trace := -1 + # First arg to iparse_tokens can be null here. + \ (next_token := iparse_tokens(&null, getchar)).sym + if \next_token then { +# write(&errout, "call of iparse_tokens via do_newline yields ", +# ximage(next_token)) + if find("b", be_tbl[next_token.sym]) + then suspend TOK("SEMICOL", "\n") + # + # See below. If this were like the real Icon parser, + # the following line would be commented out. + # + else suspend TOK(&null, "\n") + return next_token + } + else { + # + # If this were a *real* Icon tokenizer, it would not emit + # any record here, but would simply fail. Instead, we'll + # emit a dummy record with a null sym field. + # + return TOK(&null, "\n") +# &trace := 0 +# fail + } + } + + # See above. Again, if this were like Icon's own tokenizer, we + # would just fail here, and not return any TOK record. + # +# &trace := 0 + return TOK(&null, "\n") +# fail + +end + + +# +# do_number_sign: coexpression -> &null +# getchar -> +# +# Where getchar is the coexpression that pops characters off the +# main input stream. Sets the global variable next_c. This +# procedure simply reads characters until it gets a newline, then +# returns with next_c == "\n". Since the starting character was +# a number sign, this has the effect of stripping comments. +# +procedure do_number_sign(getchar) + + # global next_c + +# write(&errout, "it's a number sign") + while next_c ~== "\n" do { + next_c := @getchar + } + + # Return to calling procedure to cycle around again with the new + # next_c already set. Next_c should always be "\n" at this point. + return + +end + + +# +# do_quotation_mark: coexpression -> TOK record +# getchar -> t +# +# Where getchar is the coexpression that yields another character +# from the input stream, and t is a TOK record with "STRINGLIT" +# as its sym field. Puts everything upto and including the next +# non-backslashed quotation mark into the str field. Handles the +# underscore continuation convention. +# +procedure do_quotation_mark(getchar) + + local token + # global next_c + + # write(&errout, "it's a string literal") + token := "\"" + next_c := @getchar + repeat { + if next_c == "\n" & token[-1] == "_" then { + token := token[1:-1] + while any('\t ', next_c := @getchar) + next + } else { + if slshupto('"', token ||:= next_c, 2) + then { + next_c := @getchar + # resume outermost (repeat) loop in calling procedure, + # with the new (here explicitly set) next_c + return TOK("STRINGLIT", token) + } + next_c := @getchar + } + } + +end + + +# +# do_apostrophe: coexpression -> TOK record +# getchar -> t +# +# Where getchar is the coexpression that yields another character +# from the input stream, and t is a TOK record with "CSETLIT" +# as its sym field. Puts everything upto and including the next +# non-backslashed apostrope into the str field. +# +procedure do_apostrophe(getchar) + + local token + # global next_c + +# write(&errout, "it's a cset literal") + token := "'" + next_c := @getchar + repeat { + if next_c == "\n" & token[-1] == "_" then { + token := token[1:-1] + while any('\t ', next_c := @getchar) + next + } else { + if slshupto("'", token ||:= next_c, 2) + then { + next_c := @getchar + # Return & resume outermost containing loop in calling + # procedure w/ new next_c. + return TOK("CSETLIT", token) + } + next_c := @getchar + } + } + +end + + +# +# do_digits: coexpression -> TOK record +# getchar -> t +# +# Where getchar is the coexpression that produces the next char +# on the input stream, and where t is a TOK record containing +# either "REALLIT" or "INTLIT" in its sym field, and the text of +# the numeric literal in its str field. +# +procedure do_digits(getchar) + + local token, tok_record, extras, digits, over + # global next_c + + # For bases > 16 + extras := "AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz" + # Assume integer literal until proven otherwise.... + tok_record := TOK("INTLIT") + +# write(&errout, "it's an integer or real literal") + token := ("0" ~== next_c) | "" + while any(&digits, next_c := @getchar) do + token ||:= next_c + if token ||:= (next_c == ("R"|"r")) then { + digits := &digits + if over := ((10 < token[1:-1]) - 10) * 2 then + digits ++:= extras[1:over+1] | extras + next_c := @getchar + if next_c == "-" then { + token ||:= next_c + next_c := @getchar + } + while any(digits, next_c) do { + token ||:= next_c + next_c := @getchar + } + } else { + if token ||:= (next_c == ".") then { + while any(&digits, next_c := @getchar) do + token ||:= next_c + tok_record := TOK("REALLIT") + } + if token ||:= (next_c == ("e"|"E")) then { + next_c := @getchar + if next_c == "-" then { + token ||:= next_c + next_c := @getchar + } + while any(&digits, next_c) do { + token ||:= next_c + next_c := @getchar + } + tok_record := TOK("REALLIT") + } + } + tok_record.str := ("" ~== token) | "0" + return tok_record + +end + + +# +# do_whitespace: coexpression x cset -> &null +# getchar x whitespace -> &null +# +# Where getchar is the coexpression producing the next char on +# the input stream. Do_whitespace just repeats until it finds a +# non-whitespace character, whitespace being defined as +# membership of a given character in the whitespace argument (a +# cset). +# +procedure do_whitespace(getchar, whitespace) + +# write(&errout, "it's junk") + while any(whitespace, next_c) do + next_c := @getchar + return + +end + + +# +# do_identifier: coexpression x table -> TOK record +# (getchar, reserved_tbl) -> t +# +# Where getchar is the coexpression that pops off characters from +# the input stream, reserved_tbl is a table of reserved words +# (keys = the string values, values = the names qua symbols in +# the grammar), and t is a TOK record containing all subsequent +# letters, digits, or underscores after next_c (which must be a +# letter or underscore). Note that next_c is global and gets +# reset by do_identifier. +# +procedure do_identifier(getchar, reserved_tbl) + + local token + # global next_c + +# write(&errout, "it's an indentifier") + token := next_c + while any(&letters ++ &digits ++ '_', next_c := @getchar) + do token ||:= next_c + return TOK(\reserved_tbl[token], token) | TOK("IDENT", token) + +end + + +# +# do_operator: coexpression x list -> TOK record +# (getchar, operators) -> t +# +# Where getchar is the coexpression that produces the next +# character on the input stream, operators is the operator list, +# and where t is a TOK record describing the operator just +# scanned. Calls recognop, which creates a DFSA to recognize +# valid Icon operators. Arg2 (operators) is the list of lists +# containing valid Icon operator string values and names (see +# above). +# +procedure do_operator(getchar, operators) + + local token, elem + + token := next_c + + # Go until recognop fails. + while elem := recognop(operators, token, 1) do + token ||:= (next_c := @getchar) +# write(&errout, ximage(elem)) + if *\elem = 1 then + return TOK(elem[1][2], elem[1][1]) + else fail + +end + + +record dfstn_state(b, e, tbl) +record start_state(b, e, tbl, master_list) +# +# recognop: list x string x integer -> list +# (l, s, i) -> l2 +# +# Where l is the list of lists created by the calling procedure +# (each element contains a token string value, name, and +# beginner/ender string), where s is a string possibly +# corresponding to a token in the list, where i is the position in +# the elements of l where the operator string values are recorded, +# and where l2 is a list of elements from l that contain operators +# for which string s is an exact match. Fails if there are no +# operators that s is a prefix of, but returns an empty list if +# there just aren't any that happen to match exactly. +# +# What this does is let the calling procedure just keep adding +# characters to s until recognop fails, then check the last list +# it returned to see if it is of length 1. If it is, then it +# contains list with the vital stats for the operator last +# recognized. If it is of length 0, then string s did not +# contain any recognizable operator. +# +procedure recognop(l, s, i) + + local current_state, master_list, c, result, j + static dfstn_table + initial dfstn_table := table() + + /i := 1 + # See if we've created an automaton for l already. + /dfstn_table[l] := start_state(1, *l, &null, &null) & { + dfstn_table[l].master_list := sortf(l, i) + } + + current_state := dfstn_table[l] + # Save master_list, as current_state will change later on. + master_list := current_state.master_list + + s ? { + while c := move(1) do { + + # Null means that this part of the automaton isn't + # complete. + # + if /current_state.tbl then + create_arcs(master_list, i, current_state, &pos) + + # If the table has been clobbered, then there are no arcs + # leading out of the current state. Fail. + # + if current_state.tbl === 0 then + fail + +# write(&errout, "c = ", image(c)) +# write(&errout, "table for current state = ", +# ximage(current_state.tbl)) + + # If we get to here, the current state has arcs leading + # out of it. See if c is one of them. If so, make the + # node to which arc c is connected the current state. + # Otherwise fail. + # + current_state := \current_state.tbl[c] | fail + } + } + + # Return possible completions. + # + result := list() + every j := current_state.b to current_state.e do { + if *master_list[j][i] = *s then + put(result, master_list[j]) + } + # return empty list if nothing the right length is found + return result + +end + + +# +# create_arcs: fill out a table of arcs leading out of the current +# state, and place that table in the tbl field for +# current_state +# +procedure create_arcs(master_list, field, current_state, POS) + + local elem, i, first_char, old_first_char + + current_state.tbl := table() + old_first_char := "" + + every elem := master_list[i := current_state.b to current_state.e][field] + do { + + # Get the first character for the current position (note that + # we're one character behind the calling routine; hence + # POS-1). + # + first_char := elem[POS-1] | next + + # If we have a new first character, create a new arc out of + # the current state. + # + if first_char ~== old_first_char then { + # Store the start position for the current character. + current_state.tbl[first_char] := dfstn_state(i) + # Store the end position for the old character. + (\current_state.tbl[old_first_char]).e := i-1 + old_first_char := first_char + } + } + (\current_state.tbl[old_first_char]).e := i + + # Clobber table with 0 if no arcs were added. + current_state.tbl := (*current_state.tbl = 0) + return current_state + +end diff --git a/ipl/procs/itrcline.icn b/ipl/procs/itrcline.icn new file mode 100644 index 0000000..22a8a72 --- /dev/null +++ b/ipl/procs/itrcline.icn @@ -0,0 +1,31 @@ +############################################################################ +# +# File: itrcline.icn +# +# Subject: Procedure to filter out non-trace lines +# +# Author: Ralph E. Griswold +# +# Date: July 14, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# itrcline(f) generates lines from the file f that are Icon +# trace messages. It can, of course, be fooled. +# +############################################################################ + +procedure itrcline(f) #: generate trace messages in file + local line + + while line := read(f) do + line ? { + if (=" :" & move(6) & ="main") | (move(12) & ": |") + then suspend line + } + +end diff --git a/ipl/procs/ivalue.icn b/ipl/procs/ivalue.icn new file mode 100644 index 0000000..eeef460 --- /dev/null +++ b/ipl/procs/ivalue.icn @@ -0,0 +1,138 @@ +############################################################################ +# +# File: ivalue.icn +# +# Subject: Procedures to convert string to Icon value +# +# Author: Ralph E. Griswold +# +# Date: October 12, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure turns a string from image() into the corresponding Icon +# value. It can handle integers, real numbers, strings, csets, keywords, +# structures, and procedures. For the image of a structure, it produces a +# result of the correct type and size, but any values in the structure +# are not likely to be correct, since they are not encoded in the image. +# For procedures, the procedure must be present in the environment in +# which ivalue() is evaluated. This generally is true for built-in +# procedures (functions). +# +# All keywords are supported even if image() does not produce a string +# of the form "&name" for them. The values produced for non-constant +# keywords are, of course, the values they have in the environment in +# which ivalue() is evaluated. +# +# ivalue() also can handle non-local variables (image() does not produce +# these), but they must be present in the environment in which ivalue() +# is evaluated. +# +############################################################################ + +link escape + +procedure ivalue(___s___) #: convert string to Icon value + static ___k___ + + initial { + ___k___ := table() + ___k___["&allocated"] := &allocated + ___k___["&ascii"] := &ascii + ___k___["&clock"] := &clock + ___k___["&collections"] := &collections + ___k___["&cset"] := &cset + ___k___["¤t"] := ¤t + ___k___["&date"] := &date + ___k___["&dateline"] := &dateline + ___k___["&digits"] := &digits + ___k___["&e"] := &e + ___k___["&errornumber"] := &errornumber + ___k___["&errortext"] := &errortext + ___k___["&errorvalue"] := &errorvalue + ___k___["&errout"] := &errout + ___k___["&features"] := &features + ___k___["&file"] := &file + ___k___["&host"] := &host + ___k___["&input"] := &input + ___k___["&lcase"] := &lcase + ___k___["&letters"] := &letters + ___k___["&level"] := &level + ___k___["&line"] := &line + ___k___["&main"] := &main + ___k___["&null"] := &null + ___k___["&output"] := &output + ___k___["&phi"] := &phi + ___k___["&pi"] := &pi + ___k___["®ions"] := ®ions + ___k___["&source"] := &source + ___k___["&storage"] := &storage + ___k___["&time"] := &time + ___k___["&ucase"] := &ucase + ___k___["&version"] := &version + } + + return { + numeric(___s___) | { # integer or real + ___s___ ? { + 2(="\"", escape(tab(-1)), ="\"") | # string literal + 2(="'", cset(escape(tab(-1))), ="'") # cset literal + } + } | + ((*___s___ = 0) & &null) | # empty string = &null + \___k___[___s___] | # non-variable keyword + variable(___s___) | # variable + struct___(___s___) | { # structure + ___s___ ? { # procedure + if =("function " | "procedure " | "record contructor ") & tab(0) + then proc(___s___, 2 | 1 | 3) else fail + } + } + } + +end + +procedure struct___(s) + local type_, size, name, x + + s ? { + if { + type_ := tab(upto('_')) & # type name + move(1) & + tab(many(&digits)) & # serial number + ="(" & + size := tab(many(&digits)) & + =")" & + pos(0) + } + then { + type_ ? { + if { + ="record " & + name := tab(0) & + image(proc(name)) ? ="record constructor" + } + then return name() + } + case type_ of { + "list": return list(size) + "set": { + x := set() + every insert(x, 1 to size) + return x + } + "table": { + x := table() + every x[1 to size] := 1 + return x + } + default: fail + } + } + } + +end diff --git a/ipl/procs/jumpque.icn b/ipl/procs/jumpque.icn new file mode 100644 index 0000000..5389ed9 --- /dev/null +++ b/ipl/procs/jumpque.icn @@ -0,0 +1,37 @@ +############################################################################ +# +# File: jumpque.icn +# +# Subject: Procedure to jump element to head of queue +# +# Author: Ralph E. Griswold +# +# Date: May 9, 1992 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# jumpque(queue, y) moves y to the head of the queue if it is in queue +# but just adds y to the head of the queue if it is not already in +# the queue. A copy of queue is returned; the argument is not modified. +# +############################################################################ + +procedure jumpque(queue, y) + local x + + queue := copy(queue) + + every 1 to *queue do { # delete y from queue if it's there + x := get(queue) + if x ~=== y then put(queue, x) + } + + push(queue, y) # insert y at the head of queue + + return queue + +end diff --git a/ipl/procs/kmap.icn b/ipl/procs/kmap.icn new file mode 100644 index 0000000..f95be6e --- /dev/null +++ b/ipl/procs/kmap.icn @@ -0,0 +1,36 @@ +############################################################################ +# +# File: kmap.icn +# +# Subject: Procedure to map keyboard letter forms into letters +# +# Author: Ralph E. Griswold +# +# Date: July 15, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure maps uppercase letters and the control modifier key +# in combination with letters into the corresponding lowercase letters. +# +# It is intended for use with graphic applications in which the modifier +# keys for shift and control are encoded in keyboard events. +# +############################################################################ + +procedure kmap(s) #: map letter with modifier key to lowercase + static in, out + + initial { + in := "\^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" || &ucase + out := &lcase || &lcase + } + + return map(s, in, out) + +end diff --git a/ipl/procs/labeler.icn b/ipl/procs/labeler.icn new file mode 100644 index 0000000..aae8968 --- /dev/null +++ b/ipl/procs/labeler.icn @@ -0,0 +1,47 @@ +############################################################################ +# +# File: labeler.icn +# +# Subject: Procedure to produce successive labels +# +# Author: Gregg M. Townsend +# +# Date: April 9, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure produces a new label in sequence each time it's called. +# The labels consist of all possible combinations of the characters given +# in the argument the first time it is called. See star(s) in gener.icn +# for a generator that does the same thing (and much more concisely). +# +############################################################################ +# +# Increment a counter and convert to a label. + +procedure label(chars) + static s, abet + local i + + initial { + abet := string(chars) # initialize alphabet + s := abet[1] # initialize string + return s + } + + i := *s # start with last `digit' + while s[i] == abet[*abet] do { # while need to `carry' + s[i] := abet[1] # reset digit + i -:= 1 # move left one digit + if i = 0 then # if no more digits + return s := abet[1] || s # lengthen string + } + s[i] := abet[find(s[i],abet)+1] # normal case: incr one digit + + return s + +end diff --git a/ipl/procs/lastc.icn b/ipl/procs/lastc.icn new file mode 100644 index 0000000..c27929b --- /dev/null +++ b/ipl/procs/lastc.icn @@ -0,0 +1,85 @@ +############################################################################# +# +# File: lastc.icn +# +# Subject: Procedures for string scanning +# +# Author: David A. Gamey +# +# Date: March 25, 2002 +# +############################################################################# +# +# This file is in the public domain. +# +############################################################################# +# +# Descriptions: +# +# lastc( c, s, i1, i2 ) : i3 +# +# succeeds and produces i1, provided either +# - i1 is 1, or +# - s[i1 - 1] is in c and i2 is greater than i1 +# +# defaults: same as for any +# errors: same as for any +# +# findp( c, s1, s2, i1, i2 ) : i3, i4, ..., in +# +# generates the sequence of positions in s2 at which s1 occurs +# provided that: +# - s2 is preceded by a character in c, +# or is found at the beginning of the string +# i1 & i2 limit the search as in find +# +# defaults: same as for find +# errors: same as for find & lastc +# +# findw( c1, s1, c2, s2, i1, i2 ) : i3, i4, ..., in +# +# generates the sequence of positions in s2 at which s1 occurs +# provided that: +# - s2 is preceded by a character in c1, +# or is found at the beginning of the string; +# and +# - s2 is succeeded by a character in c2, +# or the end of the string +# i1 & i2 limit the search as in find +# +# defaults: same as for find +# errors: same as for find & lastc +# +############################################################################# + +procedure lastc( c, s, i1, i2 ) + +if /s := &subject then /i1 := &pos +/i1 := 1 +/i2 := 0 + +suspend ( ( i1 = 1 ) | any( c, s, 0 < ( i1 - 1 ), i2 ) ) +end + +procedure findp( c, s1, s2, i1, i2 ) + +if /s2 := &subject then /i1 := &pos +/i1 := 1 +/i2 := 0 + +suspend lastc( c, s2, find( s1, s2, i1, i2 ), i2 ) +end + +procedure findw( c1, s1, c2, s2, i1, i2 ) + +local csr,csr2 + +if /s2 := &subject then /i1 := &pos +/i1 := 1 +/i2 := 0 + +suspend 1( csr := findp( c1, s1, s2, i1, i2 ), + csr2 := csr + *s1, + ( csr2 = ( *s2 + 1 ) ) | any( c2, s2, csr2, i2 ) + ) +end diff --git a/ipl/procs/lastname.icn b/ipl/procs/lastname.icn new file mode 100644 index 0000000..9e14e87 --- /dev/null +++ b/ipl/procs/lastname.icn @@ -0,0 +1,33 @@ +############################################################################ +# +# File: lastname.icn +# +# Subject: Procedure to produce last name +# +# Author: Ralph E. Griswold +# +# Date: June 21, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Produces the last name of a name in conventional form. Obviously, it +# doesn't work for every possibility. +# +############################################################################ + +procedure lastname(s) + local line, i + + line := trim(s) + line ?:= tab(upto(',')) # Get rid of things like " ... , Jr." + line ? { + every i := upto(' ') + tab(\i + 1) + return tab(0) + } + +end diff --git a/ipl/procs/lcseval.icn b/ipl/procs/lcseval.icn new file mode 100644 index 0000000..b5512dd --- /dev/null +++ b/ipl/procs/lcseval.icn @@ -0,0 +1,58 @@ +############################################################################ +# +# File: lcseval.icn +# +# Subject: Procedure to evaluate linear congruence parameters +# +# Author: Ralph E. Griswold +# +# Date: May 23, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# rcseval(a, c, m) evaluates the constants used in a linear congruence +# recurrence for generating a sequence of pseudo-random numbers. +# a is the multiplicative constant, c is the additive constant, and +# m is the modulus. +# +# Any line of output starting with asterisks indicates a problem. +# +# See Donald E. Knuth, "Random Numbers" in The Art of Computer Programming, +# Vol. 2, Seminumerical Algorithms, Addison-Wesley, Reading, Massachusetts, +# 1969, pp. 1-160. +# +############################################################################ +# +# Deficiency: The modulus test for a assumes m is a power of 2. +# +############################################################################ +# +# Requires: large integers +# +############################################################################ + +procedure lcseval(a, c, m) + local b, s + + write("a=", a, " (should not have a regular pattern of digits)") + write("c=", c) + write("m=", m, " (should be large)") + + if (m / 100) < a < (m - sqrt(m)) then write("a passes range test") + else write("*** a fails range test") + if a % 8 = 5 then write("a passes mod test") + else write("*** a fails mod test") + if (c % 2) ~= 1 then write("c relatively prime to m") + else write("*** c not relatively prime to m") + write("c/m=", c / real(m), " (should be approximately 0.211324865405187)") + + b := a - 1 + + every s := seq() do + if (b ^ s) % m = 0 then stop("potency=", s, " (should be at least 5)") + +end diff --git a/ipl/procs/lindgen.icn b/ipl/procs/lindgen.icn new file mode 100644 index 0000000..d3b788c --- /dev/null +++ b/ipl/procs/lindgen.icn @@ -0,0 +1,42 @@ +############################################################################ +# +# File: lindgen.icn +# +# Subject: Procedures for rewriting 0L-systems +# +# Author: Ralph E. Griswold +# +# Date: April 5, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# lindgen() assumes a "full" mapping table; lindgenx() does not. +# +# Note that the first argument is a single character. At the top level +# it might be called as +# +# lindgen(!axiom, rewrite, gener) +# +############################################################################ + +procedure lindgen(c, rewrite, gener) #: rewrite L-system + + if gener = 0 then suspend c + else suspend lindgen(!rewrite[c], rewrite, gener - 1) + +end + +procedure lindgenx(c, rewrite, gener) #: rewrite L-system + local k + + if gener = 0 then suspend c + else every k := !c do { + k := \rewrite[k] + suspend lindgenx(!k, rewrite, gener - 1) + } + +end diff --git a/ipl/procs/lindstrp.icn b/ipl/procs/lindstrp.icn new file mode 100644 index 0000000..70d05e2 --- /dev/null +++ b/ipl/procs/lindstrp.icn @@ -0,0 +1,68 @@ +############################################################################ +# +# File: lindstrp.icn +# +# Subject: Procedure to interpret L-system output as striped pattern +# +# Author: Ralph E. Griswold +# +# Date: March 25, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Lindenmayer systems are usually are interpreted as specifications +# for drawing plant-like objects, fractals, or other geometric designs. +# This procedure illustrates that L-systems can be interpreted in other +# ways -- as striped patterns, for example. +# +# The procedure is called as lindstrp(prod, band_tbl) where prod is a +# "production" that is interpreted as being a sequence of one-character +# symbols, and band_tbl is a table with these symbols as keys whose +# corresponding values are specifications for bands of the form +# "color:width". An example of a table for the symbols A, B, and C is: +# +# band_tbl := table() +# +# band_tbl["A"] := "blue:3" +# band_tbl["B"] := "red:10" +# band_tbl["C"] := "black:5" +# +# With a table default of null, as above, symbols in prod that are not +# table keys are effectively ignored. Other table defaults +# can be used to produce different behaviors for such symbols. +# +# An example of a production is: +# +# "ABCBABC" +# +# The result is a string of band specifications for the striped pattern +# represented by prod. It can be converted to an image by using +# strplang.icn, but graphics are not necessary for the use of this +# procedure itself. +# +# One thing this procedure is useful for is developing an understanding +# of how to construct L-systems for specific purpose: L-systems for +# plant-like objects and fractals are require specialized knowledge and +# are difficult to construct, while stripes are simple enough for +# anyone to understand and develop L-systems for. +# +############################################################################ +# +# See also linden.icn and lindsys.icn. +# +############################################################################ + +procedure lindstrp(prod, band_tbl) + local result + + result := "" + + every result ||:= \band_tbl[!prod] || ";" + + return result + +end diff --git a/ipl/procs/list2tab.icn b/ipl/procs/list2tab.icn new file mode 100644 index 0000000..a490367 --- /dev/null +++ b/ipl/procs/list2tab.icn @@ -0,0 +1,33 @@ +############################################################################ +# +# File: list2tab.icn +# +# Subject: Procedure to write list as tab-separated string +# +# Author: Ralph E. Griswold +# +# Date: May 21, 1992 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure writes a list as a tab-separated string. +# Carriage returns in files are converted to vertical tabs. +# +############################################################################ +# +# See also: tab2list.icn, tab2rec.icn, rec2tab.icn +# +############################################################################ + +procedure list2tab(L) + + every writes(map(L[1 to *L - 1], "\n", "\v"),"\t") + write(map(L[-1], "\n", "\v")) + + return + +end diff --git a/ipl/procs/lists.icn b/ipl/procs/lists.icn new file mode 100644 index 0000000..2a9d4c7 --- /dev/null +++ b/ipl/procs/lists.icn @@ -0,0 +1,1355 @@ +############################################################################ +# +# File: lists.icn +# +# Subject: Procedures to manipulate lists +# +# Author: Ralph E. Griswold +# +# Date: March 5, 2003 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Contributor: Richard L. Goerwitz +# +############################################################################ +# +# file2lst(s) create list from lines in file +# +# imag2lst(s) convert limage() output to list +# +# l_Bscan(e1) begin list scanning +# +# l_Escan(l_OuterEnvir, e2) +# end list scanning +# +# l_any(l1,l2,i,j) +# any() for list scanning +# +# l_bal(l1,l2,l3,l,i,j +# bal() for list scanning +# +# l_find(l1,l2,i,j) +# find() for list scanning +# +# l_many(l1,l2,i,j) +# many() for list scanning +# +# l_match(l1,l2,i,j) +# match() for list scanning +# +# l_move(i) move() for list scanning +# +# l_pos(i) pos() for list scanning +# +# l_tab(i) tab() for list scanning +# +# l_upto(l1,l2,i,j) +# upto() for list scanning +# +# lclose(L) close open palindrome +# +# lcomb(L,i) list combinations +# +# lcompact(L) compact list, mapping out missing values +# +# ldecollate(I, L) +# list decollation +# +# ldelete(L, spec) +# list deletion +# +# ldupl(L, i) list term duplication +# +# lequiv(L1, L2) list equivalence +# +# levate(L, m, n) list elevation +# +# lextend(L, i) list extension +# +# lfliph(L) list horizontal flip (reversal) +# +# lflipv(L) list vertical flip +# +# limage(L) unadorned list image +# +# lindex(L, x) +# generate indices of L whose values are x +# +# lcollate(L1, L2, ...) +# list collation; like linterl() except stops on +# short list +# +# lconstant(L) succeeds and returns element if all are the same +# +# linterl(L1, L2) list interleaving +# +# llayer(L1, L2, ...) +# layer and interleave L1, L2, ... +# +# llpad(L, i, x) list padding at left +# +# lltrim(L, S) list left trimming +# +# lmap(L1,L2,L3) list mapping +# +# lpalin(L, x) list palindrome +# +# lpermute(L) list permutations +# +# lreflect(L, i) returns L concatenated with its reversal to produce +# palindrome; the values of i determine "end +# conditions" for the reversal: +# +# 0 omit first and last elements; default +# 1 omit first element +# 2 omit last element +# 3 don't omit element +# +# lremvals(L, x1, x2, ...) +# remove values from list +# +# lrepl(L, i) list replication +# +# lresidue(L, m, i) +# list residue +# +# lreverse(L) list reverse +# +# lrotate(L, i) list rotation +# +# lrpad(L, i, x) list right padding +# +# lrundown(L1, L2, L3) +# list run down +# +# lrunup(L1, L2, L3) +# list run up +# +# lrtrim(L, S) list right trimming +# +# lshift(L, i) shift list terms +# +# lst2str(L) string from concatenated values in L +# +# lswap(L) list element swap +# +# lunique(L) keep only unique list elements +# +# lmaxlen(L, p) returns the size of the largest value in L. +# If p is given, it is applied to each string as +# as a "length" procedure. The default for p is +# proc("*", 1). +# +# lminlen(L, p) returns the size of the smallest value in L. +# If p is given, it is applied to each string as +# as a "length" procedure. The default for p is +# proc("*", 1). +# +# sortkeys(L) returns list of keys from L, where L is the +# result of sorting a table with option 3 or 4. +# +# sortvalues(L) return list of values from L, where L is the +# result of sorting a table with option 3 or 4. +# +# str2lst(s, i) creates list with i-character lines from s. The +# default for i is 1. +# +############################################################################ +# +# About List Mapping +# +# The procedure lmap(L1,L2,L3) maps elements of L1 according to L2 +# and L3. This procedure is the analog for lists of the built-in +# string-mapping function map(s1,s2,s3). Elements in L1 that are +# the same as elements in L2 are mapped into the corresponding ele- +# ments of L3. For example, given the lists +# +# L1 := [1,2,3,4] +# L2 := [4,3,2,1] +# L3 := ["a","b","c","d"] +# +# then +# +# lmap(L1,L2,L3) +# +# produces a new list +# +# ["d","c","b","a"] +# +# Lists that are mapped can have any kinds of elements. The +# operation +# +# x === y +# +# is used to determine if elements x and y are equivalent. +# +# All cases in lmap are handled as they are in map, except that +# no defaults are provided for omitted arguments. As with map, lmap +# can be used for transposition as well as substitution. +# +# Warning: +# +# If lmap is called with the same lists L2 and L3 as in +# the immediately preceding call, the same mapping is performed, +# even if the values in L2 and L3 have been changed. This improves +# performance, but it may cause unexpected effects. +# +# This ``caching'' of the mapping table based on L2 and L3 +# can be easily removed to avoid this potential problem. +# +############################################################################ +# +# About List Scanning by Richard L. Goerwitz +# +# PURPOSE: String scanning is terrific, but often I am forced to +# tokenize and work with lists. So as to make operations on these +# lists as close to corresponding string operations as possible, I've +# implemented a series of list analogues to any(), bal(), find(), +# many(), match(), move(), pos(), tab(), and upto(). Their names are +# just like corresponding string functions, except with a prepended +# "l_" (e.g. l_any()). Functionally, the list routines parallel the +# string ones closely, except that in place of strings, l_find and +# l_match accept lists as their first argument. L_any(), l_many(), +# and l_upto() all take either sets of lists or lists of lists (e.g. +# l_tab(l_upto([["a"],["b"],["j","u","n","k"]])). Note that l_bal(), +# unlike the builtin bal(), has no defaults for the first four +# arguments. This just seemed appropriate, given that no precise +# list analogue to &cset, etc. occurs. +# +# The default subject for list scans (analogous to &subject) is +# l_SUBJ. The equivalent of &pos is l_POS. Naturally, these +# variables are both global. They are used pretty much like &subject +# and &pos, except that they are null until a list scanning +# expression has been encountered containing a call to l_Bscan() (on +# which, see below). +# +# Note that environments cannot be maintained quite as elegantly as +# they can be for the builtin string-scanning functions. One must +# use instead a set of nested procedure calls, as explained in the +# _Icon Analyst_ 1:6 (June, 1991), p. 1-2. In particular, one cannot +# suspend, return, or otherwise break out of the nested procedure +# calls. They can only be exited via failure. The names of these +# procedures, at least in this implementation, are l_Escan and +# l_Bscan. Here is one example of how they might be invoked: +# +# suspend l_Escan(l_Bscan(some_list_or_other), { +# l_tab(10 to *l_SUBJ) & { +# if l_any(l1) | l_match(l2) then +# old_l_POS + (l_POS-1) +# } +# }) +# +# Note that you cannot do this: +# +# l_Escan(l_Bscan(some_list_or_other), { +# l_tab(10 to *l_SUBJ) & { +# if l_any(l1) | l_match(l2) then +# suspend old_l_POS + (l_POS-1) +# } +# }) +# +# Remember, it's no fair to use suspend within the list scanning +# expression. l_Escan must do all the suspending. It is perfectly OK, +# though, to nest well-behaved list scanning expressions. And they can +# be reliably used to generate a series of results as well. +# +############################################################################ +# +# Here's another simple example of how one might invoke the l_scan +# routines: +# +# procedure main() +# +# l := ["h","e","l","l","o"," ","t","t","t","h","e","r","e"] +# +# l_Escan(l_Bscan(l), { +# hello_list := l_tab(l_match(["h","e","l","l","o"])) +# every writes(!hello_list) +# write() +# +# # Note the nested list-scanning expressions. +# l_Escan(l_Bscan(l_tab(0)), { +# l_tab(l_many([[" "],["t"]]) - 1) +# every writes(!l_tab(0)) +# write() +# }) +# }) +# +# end +# +# The above program simply writes "hello" and "there" on successive +# lines to the standard output. +# +############################################################################ +# +# PITFALLS: In general, note that we are comparing lists here instead +# of strings, so l_find("h", l), for instance, will yield an error +# message (use l_find(["h"], l) instead). The point at which I +# expect this nuance will be most confusing will be in cases where +# one is looking for lists within lists. Suppose we have a list, +# +# l1 := ["junk",[["hello"]," ",["there"]],"!","m","o","r","e","junk"] +# +# and suppose, moreover, that we wish to find the position in l1 at +# which the list +# +# [["hello"]," ",["there"]] +# +# occurs. If, say, we assign [["hello"]," ",["there"]] to the +# variable l2, then our l_find() expression will need to look like +# +# l_find([l2],l1) +# +############################################################################ +# +# Extending scanning to lists is really very difficult. What I think +# (at least tonight) is that scanning should never have been +# restricted to strings. It should have been designed to operate on +# all homogenous one-dimensional arrays (vectors, for you LISPers). +# You should be able, in other words, to scan vectors of ints, longs, +# characters - any data type that seems useful. The only question in +# my mind is how to represent vectors as literals. Extending strings +# to lists goes beyond the bounds of scanning per-se. This library is +# therefore something of a stab in the dark. +# +############################################################################ +# +# Links: equiv, indices, numbers +# +############################################################################ + +link equiv +link indices +link numbers + +procedure file2lst(s) #: create list from lines in file + local input, result + + input := open(s) | fail + + result := [] + + every put(result, !input) + + close(input) + + return result + +end + +procedure imag2lst(seqimage) #: convert limage() output to list + local seq, term + + seq := [] + + seqimage[2:-1] ? { + if pos(0) then return seq + tab(many(' ')) + while term := tab(bal(',', '[', ']') | 0) do { + term := numeric(term) # special interest + put(seq, term) + move(1) | break + tab(many(' ')) + } + } + + return seq + +end + +global l_POS +global l_SUBJ + +record l_ScanEnvir(subject,pos) + +procedure l_Bscan(e1) #: begin list scanning + + # + # Prototype list scan initializer. Based on code published in + # the _Icon Analyst_ 1:6 (June, 1991), p. 1-2. + # + local l_OuterEnvir + initial { + l_SUBJ := [] + l_POS := 1 + } + + # + # Save outer scanning environment. + # + l_OuterEnvir := l_ScanEnvir(l_SUBJ, l_POS) + + # + # Set current scanning environment to subject e1 (arg 1). Pos + # defaults to 1. Suspend the saved environment. Later on, the + # l_Escan procedure will need this in case the scanning expres- + # sion as a whole sends a result back to the outer environment, + # and the outer environment changes l_SUBJ and l_POS. + # + l_SUBJ := e1 + l_POS := 1 + suspend l_OuterEnvir + + # + # Restore the saved environment (plus any changes that might have + # been made to it as noted in the previous run of comments). + # + l_SUBJ := l_OuterEnvir.subject + l_POS := l_OuterEnvir.pos + + # + # Signal failure of the scanning expression (we're done producing + # results if we get to here). + # + fail + +end + + + +procedure l_Escan(l_OuterEnvir, e2) #: end list scanning + + local l_InnerEnvir + + # + # Set the inner scanning environment to the values assigned to it + # by l_Bscan. Remember that l_SUBJ and l_POS are global. They + # don't need to be passed as parameters from l_Bscan. What + # l_Bscan() needs to pass on is the l_OuterEnvir record, + # containing the values of l_SUBJ and l_POS before l_Bscan() was + # called. l_Escan receives this "outer environment" as its first + # argument, l_OuterEnvir. + # + l_InnerEnvir := l_ScanEnvir(l_SUBJ, l_POS) + + # + # Whatever expression produced e2 has passed us a result. Now we + # restore l_SUBJ and l_POS, and send that result back to the outer + # environment. + # + l_SUBJ := l_OuterEnvir.subject + l_POS := l_OuterEnvir.pos + suspend e2 + + # + # Okay, we've resumed to (attempt to) produce another result. Re- + # store the inner scanning environment (the one we're using in the + # current scanning expression). Remember? It was saved in l_Inner- + # Envir just above. + # + l_SUBJ := l_InnerEnvir.subject + l_POS := l_InnerEnvir.pos + + # + # Fail so that the second argument (the one that produced e2) gets + # resumed. If it fails to produce another result, then the first + # argument is resumed, which is l_Bscan(). If l_Bscan is resumed, it + # will restore the outer environment and fail, causing the entire + # scanning expression to fail. + # + fail + +end + +procedure l_any(l1,l2,i,j) #: any() for list scanning + + # + # Like any(c,s2,i,j) except that the string & cset arguments are + # replaced by list arguments. l1 must be a list of one-element + # lists, while l2 can be any list (l_SUBJ by default). + # + + local x, sub_l + + /l1 & stop("l_any: Null first argument!") + if type(l1) == "set" then l1 := sort(l1) + + /l2 := l_SUBJ + if \i then { + if i < 1 then + i := *l2 + (i+1) + } + else i := \l_POS | 1 + if \j then { + if j < 1 then + j := *l2 + (j+1) + } + else j := *l_SUBJ+1 + + (i+1) > j & i :=: j + every sub_l := !l1 do { + if not (type(sub_l) == "list", *sub_l = 1) then + stop("l_any: Elements of l1 must be lists of length 1.") + # Let l_match check to see if i+1 is out of range. + if x := l_match(sub_l,l2,i,i+1) then + return x + } + +end + +procedure l_bal(l1,l2,l3,l,i,j) #: bal() for list scanning + + local default_val, l2_count, l3_count, x, position + + /l1 & stop("l_bal: Null first argument!") + if type(l1) == "set" then l1 := sort(l1) # convert to a list + if type(l2) == "set" then l1 := sort(l2) + if type(l3) == "set" then l1 := sort(l3) + + if /l2 := l_SUBJ + then default_val := \l_POS | 1 + else default_val := 1 + + if \i then { + if i < 1 then + i := *l2 + (i+1) + } + else i := default_val + + if \j then { + if j < 1 then + j := *l2 + (j+1) + } + else j := *l_SUBJ+1 + + l2_count := l3_count := 0 + + every x := i to j-1 do { + + if l_any(l2, l, x, x+1) then { + l2_count +:= 1 + } + if l_any(l3, l, x, x+1) then { + l3_count +:= 1 + } + if l2_count = l3_count then { + if l_any(l1,l,x,x+1) + then suspend x + } + } + +end + +procedure l_comp(l1,l2) # list comparison + + # + # List comparison routine basically taken from Griswold & Griswold + # (1st ed.), p. 174. + # + + local i + + /l1 | /l2 & stop("l_comp: Null argument!") + l1 === l2 & (return l2) + + if type(l1) == type(l2) == "list" then { + *l1 ~= *l2 & fail + every i := 1 to *l1 + do l_comp(l1[i],l2[i]) | fail + return l2 + } + +end + +procedure l_find(l1,l2,i,j) #: find() for list scanning + + # + # Like the builtin find(s1,s2,i,j), but for lists. + # + + local x, old_l_POS, default_val + + /l1 & stop("l_find: Null first argument!") + + if /l2 := l_SUBJ + then default_val := \l_POS | 1 + else default_val := 1 + + if \i then { + if i < 1 then + i := *l2 + (i+1) + } + else i := default_val + + if \j then { + if j < 1 then + j := *l2 + (j+1) + } + else j := *l_SUBJ+1 + + # + # See l_upto() below for a discussion of why things have to be done + # in this manner. + # + old_l_POS := l_POS + + suspend l_Escan(l_Bscan(l2[i:j]), { + l_tab(1 to *l_SUBJ) & { + if l_match(l1) then + old_l_POS + (l_POS-1) + } + }) + +end + +procedure l_many(l1,l2,i,j) #: many() for list scanning + + local x, old_l_POS, default_val + + /l1 & stop("l_many: Null first argument!") + if type(l1) == "set" then l1 := sort(l1) + + if /l2 := l_SUBJ + then default_val := \l_POS | 1 + else default_val := 1 + + if \i then { + if i < 1 then + i := *l2 + (i+1) + } + else i := default_val + + if \j then { + if j < 1 then + j := *l2 + (j+1) + } + else j := *l_SUBJ+1 + + # + # L_many(), like many(), is not a generator. We can therefore + # save one final result in x, and then later return (rather than + # suspend) that result. + # + old_l_POS := l_POS + l_Escan(l_Bscan(l2[i:j]), { + while l_tab(l_any(l1)) + x := old_l_POS + (l_POS-1) + }) + + # + # Fails if there was no positional change (i.e. l_any() did not + # succeed even once). + # + return old_l_POS ~= x + +end + +procedure l_match(l1,l2,i,j) #: match() for list scanning + + # + # Analogous to match(s1,s2,i,j), except that s1 and s2 are lists, + # and l_match returns the next position in l2 after that portion + # (if any) which is structurally identical to l1. If a match is not + # found, l_match fails. + # + local default_val + + if /l1 + then stop("l_match: Null first argument!") + if type(l1) ~== "list" + then stop("l_match: Call me with a list as the first arg.") + + if /l2 := l_SUBJ + then default_val := \l_POS | 1 + else default_val := 1 + + if \i then { + if i < 1 then + i := *l2 + (i+1) + } + else i := default_val + + if \j then { + if j < 1 then + j := *l2 + (j+1) + } + else j := *l_SUBJ+1 + + i + *l1 > j & i :=: j + i + *l1 > j & fail + if l_comp(l1,l2[i+:*l1]) then + return i + *l1 + +end + +procedure l_move(i) #: move() for list scanning + + /i & stop("l_move: Null argument.") + if /l_POS | /l_SUBJ then + stop("l_move: Call l_Bscan() first.") + + # + # Sets l_POS to l_POS+i; suspends that portion of l_SUBJ extending + # from the old l_POS to the new one. Resets l_POS if resumed, + # just the way matching procedures are supposed to. Fails if l_POS + # plus i is larger than l_SUBJ+1 or if l_POS+i is less than 1. + # + suspend l_SUBJ[.l_POS:l_POS <- (0 < (*l_SUBJ+1 >= l_POS+i))] + +end + +procedure l_pos(i) #: pos() for list scanning + + local x + + if /l_POS | /l_SUBJ + then stop("l_move: Call l_Bscan() first.") + + if i <= 0 + then x := 0 < (*l_SUBJ+1 >= (*l_SUBJ+1)+i) | fail + else x := 0 < (*l_SUBJ+1 >= i) | fail + + if x = l_POS + then return x + else fail + +end + +procedure l_tab(i) #: tab() for list scanning + + /i & stop("l_tab: Null argument.") + if /l_POS | /l_SUBJ then + stop("l_tab: Call l_Bscan() first.") + + if i <= 0 + then suspend l_SUBJ[.l_POS:l_POS <- 0 < (*l_SUBJ+1 >= (*l_SUBJ+1)+i)] + else suspend l_SUBJ[.l_POS:l_POS <- 0 < (*l_SUBJ+1 >= i)] + +end + +procedure l_upto(l1,l2,i,j) #: upto() for list scanning + + # + # See l_any() above. This procedure just moves through l2, calling + # l_any() for each member of l2[i:j]. + # + + local old_l_POS, default_val + + /l1 & stop("l_upto: Null first argument!") + if type(l1) == "set" then l1 := sort(l1) + + if /l2 := l_SUBJ + then default_val := \l_POS | 1 + else default_val := 1 + + if \i then { + if i < 1 then + i := *l2 + (i+1) + } + else i := default_val + + if \j then { + if j < 1 then + j := *l2 + (j+1) + } + else j := *l_SUBJ+1 + + # + # Save the old pos, then try arb()ing through the list to see if we + # can do an l_any(l1) at any position. + # + old_l_POS := l_POS + + suspend l_Escan(l_Bscan(l2[i:j]), { + l_tab(1 to *l_SUBJ) & { + if l_any(l1) then + old_l_POS + (l_POS-1) + } + }) + + # + # Note that it WILL NOT WORK if you say: + # + # l_Escan(l_Bscan(l2[i:j]), { + # l_tab(1 to *l_SUBJ) & { + # if l_any(l1) then + # suspend old_l_POS + (l_POS-1) + # } + # }) + # + # If we are to suspend a result, l_Escan must suspend that result. + # Otherwise scanning environments are not saved and/or restored + # properly. + # + +end + +procedure lblock(L1, L2) + local L3, i, j + + if *L1 < *L2 then L1 := lextend(L1, *L2) | fail + else if *L2 < *L1 then L2 := lextend(L2, *L1) | fail + + L3 := [] + + every i := 1 to *L1 do + every j := 1 to L2[i] do + put(L3, L2[i]) + + return L3 + +end + +procedure llayer(args[]) #: interleave lists with layering + local offsets, offset, seq, arg, lists, k + + lists := [] + + every put(lists, lcompact(!args)) + + offsets := [] + + offset := 0 + + every arg := !lists do { + put(offsets, offset) + offset +:= max ! arg + } + + seq := [] + + repeat { + every k := 1 to *lists do { + arg := lists[k] + put(seq, get(arg) + offsets[k]) | break break + } + } + + return seq + +end + +procedure lcompact(seq) #: compact sequence + local unique, target + + unique := set(seq) + + target := [] + + every put(target, 1 to *unique) + + return lmap(seq, sort(unique), target) + +end + +procedure lclose(L) #: close open palindrome + + if equiv(L, lreverse(L)) then return L + else { + L := copy(L) + put(L, L[1]) + return L + } + +end + +procedure lcomb(L,i) #: list combinations + local j + + if i < 1 then fail + suspend if i = 1 then [!L] + else [L[j := 1 to *L - i + 1]] ||| lcomb(L[j + 1:0],i - 1) + +end + +procedure ldecollate(indices, L) #: list decollation + local result, i, x + + result := list(max ! indices) # list of lists to return + every !result := [] # initially empty + + every x := !L do { + i := get(indices) | fail + put(indices, i) + put(result[i], x) + } + + return result + +end + +procedure ldelete(L, spec) #: delete specified list elements + local i, tmp + + tmp := indices(spec, *L) | fail # bad specification + + while i := pull(tmp) do + L := L[1+:i - 1] ||| L[i + 1:0] + + return L + +end + +procedure ldupl(L1, L2) #: list term duplication + local L3, i, j + + if integer(L2) then L2 := [L2] + + L3 := [] + + every i := !L2 do + every j := !L1 do + every 1 to i do + put(L3, j) + + return L3 + +end + +procedure lequiv(x,y) #: compare lists for equivalence + local i + + if x === y then return y + if type(x) == type(y) == "list" then { + if *x ~= *y then fail + every i := 1 to *x do + if not lequiv(x[i],y[i]) then fail + return y + } + +end + +procedure levate(seq, m, n) #: elevate values + local shafts, reseq, i, j, k + + shafts := list(m) + + every !shafts := [] + + every i := 1 to m do + every put(shafts[i], i to n by m) + + reseq := [] + + while j := get(seq) do { + i := j % m + 1 + k := get(shafts[i]) + put(reseq, k) + put(shafts[i], k) + } + + return reseq + +end + +procedure lextend(L, i) #: list extension + local result + + if *L = 0 then fail + + result := copy(L) + + until *result >= i do + result |||:= L + + result := result[1+:i] + + return result + +end + +procedure lfliph(L) #: list horizontal flip (reversal) + + lfliph := lreverse + + return lfliph(L) + +end + +procedure lflipv(L) #: list vertical flip + local L1, m, i + + m := max ! L + + L1 := [] + + every i := !L do + put(L1, residue(-i + 1, m, 1)) + + return L1 + +end + +procedure limage(L) #: list image + local result + + if type(L) ~== "list" then stop("*** invalid type to limage()") + + result := "" + + every result ||:= image(!L) || "," + + return ("[" || result[1:-1] || "]") | "[]" + +end + +procedure lcollate(args[]) #: generalized list collation + local seq, arg, lists, k + + lists := [] + + every put(lists, copy(!args)) + + seq := [] + + repeat { + every k := 1 to *lists do { + arg := lists[k] + put(seq, get(arg)) | break break + } + } + + return seq + +end + +procedure lconstant(L) #: test list for all terms equal + + if *set(L) = 1 then return L[1] + else fail + +end + +procedure lindex(lst, x) #: generate indices for items matching x + local i + + every i := 1 to *lst do + if lst[i] === x then suspend i + +end + +procedure linterl(L1, L2) #: list interleaving + local L3, i + + if *L1 < *L2 then L1 := lextend(L1, *L2) | fail + else if *L2 < *L1 then L2 := lextend(L2, *L1) | fail + + L3 := [] + + every i := 1 to *L1 do + put(L3, L1[i], L2[i]) + + return L3 + +end + +procedure llpad(L, i, x) #: list padding at left + + L := copy(L) + + while *L < i do push(L, x) + + return L + +end + +procedure lrunup(L1, L2, L3) #: list run up + local L4 + + /L3 := [1] # could be /L3 := 1 ... + + L4 := [] + + every put(L4, !L1 to !L2 by !L3) + + return L4 + +end + +procedure lrundown(L1, L2, L3) #: list run up + local L4 + + /L3 := [1] # could be /L3 := 1 ... + + L4 := [] + + every put(L4, !L1 to !L2 by -!L3) + + return L4 + +end + +procedure lltrim(L, S) #: list left trimming + + L := copy(L) + + while member(S, L[1]) do + get(L) + + return L + +end + +procedure lmap(L1,L2,L3) #: list mapping + static lmem2, lmem3, lmaptbl, tdefault + local i, a + + initial tdefault := [] + + if type(a := L1 | L2 | L3) ~== "list" then runerr(108,a) + if *L2 ~= *L3 then runerr(208,L2) + + L1 := copy(L1) + + if not(lmem2 === L2 & lmem3 === L3) then { # if an argument is new, rebuild + lmem2 := L2 # save for future reference + lmem3 := L3 + lmaptbl := table(tdefault) # new mapping table + every i := 1 to *L2 do # build the map + lmaptbl[L2[i]] := L3[i] + } + every i := 1 to *L1 do # map the values + L1[i] := (tdefault ~=== lmaptbl[L1[i]]) + return L1 + +end + +procedure lresidue(L, m, i) #: list residue + local result + + /i := 0 + + result := [] + + every put(result, residue(!L, m, i)) + + return result + +end + +procedure lpalin(L, x) #: list palindrome + + L |||:= lreverse(L) + + if /x then pull(L) + + return L + +end + +procedure lpermute(L) #: list permutations + local i + + if *L = 0 then return [] + suspend [L[i := 1 to *L]] ||| lpermute(L[1:i] ||| L[i+1:0]) + +end + +procedure lreflect(L, i) #: list reflection + local L1 + + /i := 0 + + if i > 3 then stop("*** invalid argument to lreflect()") + + if i < 3 then L1 := copy(L) + + return L ||| lreverse( + case i of { + 0: {get(L1); pull(L1); L1} + 1: {get(L1); L1} + 2: {pull(L1); L1} + 3: L + } + ) + +end + +procedure lremvals(L, x[]) #: remove values from list + local result, y + + result := [] + + every y := !L do + if y === !x then next + else put(result, y) + + return result + +end + +procedure lrepl(L, i) #: list replication + local j, k + + i := (0 < integer(i)) | stop("*** invalid replication factor in lrepl()") + + L := copy(L) + + j := *L + + every 1 to i - 1 do + every k := 1 to j do + put(L, L[k]) + + return L + +end + +procedure lreverse(L) #: list reverse + local i + + L := copy(L) + + every i := 1 to *L / 2 do + L[i] :=: L[-i] + + return L + +end + +procedure lrotate(L, i) #: list rotation + + /i := 1 + + L := copy(L) + + if i > 0 then + every 1 to i do + put(L, get(L)) + else + every 1 to -i do + push(L, pull(L)) + + return L + +end + +procedure lrpad(L, i, x) #: list right padding + + L := copy(L) + + while *L < i do put(L, x) + + return L + +end + +procedure lrtrim(L, S) #: list right trimming + + L := copy(L) + + while member(S, L[-1]) do + pull(L) + + return L + +end + +procedure lshift(L, i) #: shift list terms + + L := copy(L) + + every !L +:= i + + return L + +end + +procedure lst2str(L) #: convert list to string + local str + + str := "" + + every str ||:= !L + + return str + +end + +procedure lswap(L) #: list element swap + local i + + L := copy(L) + + every i := 1 to *L by 2 do + L[i] :=: L[i + 1] + + return L + +end + +procedure lunique(L) #: keep only unique list elements + local result, culls, x + + result := [] + culls := set(L) + + every x := !L do + if member(culls, x) then { + delete(culls, x) + put(result, x) + } + + return result + +end + +procedure lmaxlen(L, p) #: size of largest list entry + local i + + /p := proc("*", 1) + + i := p(L[1]) | fail + + every i <:= p(!L) + + return i + +end + +procedure lminlen(L, p) #: size of smallest list entry + local i + + /p := proc("*", 1) + + i := p(L[1]) | fail + + every i >:= p(!L) + + return i + +end + +procedure sortkeys(L) #: extract keys from sorted list + local result + + result := [] + + every put(result, L[1 to *L by 2]) + + return result + +end + +procedure sortvalues(L) #: extract values from sorted list + local result + + result := [] + + every put(result, L[2 to *L by 2]) + + return result + +end + +procedure str2lst(s, i) #: list from string + local L + + /i := 1 + + L := [] + + s ? { + while put(L, move(i)) + if not pos(0) then put(L, tab(0)) + } + + return L + +end diff --git a/ipl/procs/longstr.icn b/ipl/procs/longstr.icn new file mode 100644 index 0000000..c0231fb --- /dev/null +++ b/ipl/procs/longstr.icn @@ -0,0 +1,90 @@ +############################################################################ +# +# File: longstr.icn +# +# Subject: Procedure to match longest string +# +# Author: Jerry Nowlin +# +# Date: June 1, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Contributors: Stephen B. Wampler, Kenneth Walker, Bob Alexander, +# and Richard E. Goerwitz +# +############################################################################ +# +# Version: 1.9 +# +############################################################################ +# +# longstr(l,s,i,j) works like any(), except that instead of taking a +# cset as its first argument, it takes instead a list or set of +# strings (l). Returns i + *x, where x is the longest string in l +# for which match(x,s,i,j) succeeds. Fails if no match occurs. +# +# Defaults: +# s &subject +# i &pos if s is defaulted, otherwise 1 +# j 0 +# +# Errors: +# The only manual error-checking that is done is to test l to +# be sure it is, in fact, a list or set. Errors such as non- +# string members in l, and non-integer i/j parameters, are +# caught by the normal Icon built-in string processing and sub- +# scripting mechanisms. +# +############################################################################ + +procedure longstr(l,s,i,j) + + local elem, tmp_table + static l_table + initial l_table := table() + + # + # No-arg invocation wipes out all static structures, and forces an + # immediate garbage collection. + # + if (/l, /s) then { + l_table := table() + collect() # do it NOW + return # return &null + } + + # + # Is l a list, set, or table? + # + type(l) == ("list"|"set"|"table") | + stop("longstr: list, set, or table expected (arg 1)") + + # + # Sort l longest-to-shortest, and keep a copy of the resulting + # structure in l_table[l] for later use. + # + if /l_table[l] := [] then { + + tmp_table := table() + # keys = lengths of elements, values = elements + every elem := !l do { + /tmp_table[*elem] := [] + put(tmp_table[*elem], elem) + } + # sort by key; stuff values, in reverse order, into a list + every put(l_table[l], !sort(tmp_table,3)[*tmp_table*2 to 2 by -2]) + + } + + # + # First element in l_table[l] to match is the longest match (it's + # sorted longest-to-shortest, remember?). + # + return match(!l_table[l],s,i,j) + +end diff --git a/ipl/procs/lrgapprx.icn b/ipl/procs/lrgapprx.icn new file mode 100644 index 0000000..cfddc85 --- /dev/null +++ b/ipl/procs/lrgapprx.icn @@ -0,0 +1,36 @@ +############################################################################ +# +# File: lrgapprx.icn +# +# Subject: Procedure to approximate integer values +# +# Author: Ralph E. Griswold +# +# Date: September 14, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure produces an approximate of an integer value in the +# form n.nx10^n. +# +# It is primarily useful for large integers. +# +############################################################################ + +procedure lrgapprx(i) + local head, carry + + i ? { + head := move(2) | return i + if carry := move(1) then { + if carry > 5 then head +:= 1 + move(-1) + } + return real(head / 10.0) || "x10^" || (*tab(0) + 1) + } + +end diff --git a/ipl/procs/lstfncs.icn b/ipl/procs/lstfncs.icn new file mode 100644 index 0000000..98e0fc3 --- /dev/null +++ b/ipl/procs/lstfncs.icn @@ -0,0 +1,78 @@ +############################################################################ +# +# File: lstfncs.icn +# +# Subject: Procedures to produce lists from sequences +# +# Author: Ralph E. Griswold +# +# Date: April 23, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Links: genrfncs, numbers +# +############################################################################ + +link genrfncs +link numbers + +procedure fiblist(l, m) + local result + + /l := 128 + /m := 8 + + result := [] + + every put(result, residue(fibseq(), m, 1)) \ l + + return result + +end + +procedure multilist(l, m) + local result + + /l := 128 + /m := 8 + + result := [] + + every put(result, residue(multiseq(), m, 1)) \ l + + return result + +end + +procedure primelist(l, m) + local result + + /l := 128 + /m := 8 + + result := [] + + every put(result, residue(primeseq(), m, 1)) \ l + + return result + +end + +procedure List(L) # called as List{e, l, m} + local l, m, result + + l := \@L[2] | 128 # length + m := \@L[3] | 8 # modulus + + result := [] + + every put(result, residue(|@L[1], m, 1)) \ l + + return result + +end diff --git a/ipl/procs/lterps.icn b/ipl/procs/lterps.icn new file mode 100644 index 0000000..a8ac521 --- /dev/null +++ b/ipl/procs/lterps.icn @@ -0,0 +1,43 @@ +############################################################################ +# +# File: lterps.icn +# +# Subject: Procedure to interpret L-system output +# +# Author: Ralph E. Griswold +# +# Date: September 30, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Links: numbers +# +############################################################################ + +link numbers + +procedure seqterp(s) #: interpret L-system output + local c + static incr, pos + + initial { + incr := 1 + pos := 0 + } + + every c := !s do + case c of { + "F" : { + pos +:= incr + suspend pos + } + "f" : pos +:= incr + "+" : incr := 1 + "-" : incr := -1 + } + +end diff --git a/ipl/procs/lu.icn b/ipl/procs/lu.icn new file mode 100644 index 0000000..ff89589 --- /dev/null +++ b/ipl/procs/lu.icn @@ -0,0 +1,144 @@ +############################################################################ +# +# File: lu.icn +# +# Subject: Procedures for LU manipulation +# +# Author: Ralph E. Griswold +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# lu_decomp(M, I) performs LU decomposition on the square matrix M +# using the vector I. Both M and I are modified in the process. The +# value returned is +1 or -1 depending on whether the number of row +# interchanges is even or odd. lu_decomp() is used in combination with +# lu_back_sub() to solve linear equations or invert matrices. +# +# lu_decomp() fails if the matrix is singular. +# +# lu_back_sub(M, I, B) solves the set of linear equations M x X = B. M +# is the matrix as modified by lu_decomp(). I is the index vector +# produced by lu_decomp(). B is the right-hand side vector and return +# with the solution vector. M and I are not modified by lu_back_sub() +# and can be used in successive calls of lu_back_sub() with different +# Bs. +# +############################################################################ +# +# Acknowledgement: These procedures are based on algorithms given in +# "Numerical Recipes; The Art of Scientific Computing"; William H. Press, +# Brian P. Flannery, Saul A. Teukolsky. and William T. Vetterling; +# Cambridge University Press, 1986. +# +############################################################################ + +procedure lu_decomp(M, I) + local small, d, n, vv, i, largest, j, sum, k, pivot_val, imax + + initial small := 1.0e-20 + + d := 1.0 + + n := *M + if n ~= *M[1] then stop("*** non-square matrix") + if n ~= *I then stop("*** index vector incorrect length") + + vv := list(n, 0.0) # scaling vector + + every i := 1 to n do { + largest := 0.0 + every j := 1 to n do + largest <:= abs(M[i][j]) + if largest = 0.0 then fail # matrix is singular + vv[i] := 1.0 / largest + } + + every j := 1 to n do { # Crout's method + if j > 1 then { + every i := 1 to j - 1 do { + sum := M[i][j] + if i > 1 then { + every k := 1 to i - 1 do + sum -:= M[i][k] * M[k][j] + M[i][j] := sum + } + } + } + + largest := 0.0 # search for largest pivot + every i := j to n do { + sum := M[i][j] + if j > 1 then { + every k := 1 to j - 1 do + sum -:= M[i][k] * M[k][j] + M[i][j] := sum + } + pivot_val := vv[i] * abs(sum) + if pivot_val > largest then { + largest := pivot_val + imax := i + } + } + + if j ~= imax then { # interchange rows? + every k := 1 to n do { + pivot_val := M[imax][k] + M[imax][k] := M[j][k] + M[j][k] := pivot_val + } + d := -d # change parity + vv[imax] := vv[j] # and scale factor + } + I[j] := imax + if j ~= n then { # divide by the pivot element + if M[j][j] = 0.0 then M[j][j] := small # small value is better than + pivot_val := 1.0 / M[j][j] # zero for some applications + every i := j + 1 to n do + M[i][j] *:= pivot_val + } + } + + if M[n][n] = 0.0 then M[n][n] := small + + return d + +end + +procedure lu_back_sub(M, I, B) + local n, ii, i, ip, sum, j + + n := *M + if n ~= *M[1] then stop("*** matrix not square") + if n ~= *I then stop("*** index vector wrong length") + if n ~= *B then stop("*** output vector wrong length") + + ii := 0 + + every i := 1 to n do { + ip := I[i] | stop("failed in line ", &line) + sum := B[ip] | stop("failed in line ", &line) + B[ip] := B[i] | stop("failed in line ", &line) + if ii ~= 0 then + every j := ii to i - 1 do + sum -:= M[i][j] * B[j] | stop("failed in line ", &line) + else if sum ~= 0.0 then ii := i + B[i] := sum | stop("failed in line ", &line) + } + every i := n to 1 by -1 do { + sum := B[i] | stop("failed in line ", &line) + if i < n then { + every j := i + 1 to n do + sum -:= M[i][j] * B[j] | stop("failed in line ", &line) + } + B[i] := sum / M[i][i] | stop("failed in line ", &line) + } + + return + +end diff --git a/ipl/procs/makelsys.icn b/ipl/procs/makelsys.icn new file mode 100644 index 0000000..c343626 --- /dev/null +++ b/ipl/procs/makelsys.icn @@ -0,0 +1,78 @@ +############################################################################ +# +# File: makelsys.icn +# +# Subject: Procedures to convert L-Systems to records +# +# Author: Ralph E. Griswold +# +# Date: January 23, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures coverts a list corresponding to an L-System into an +# L-System record. +# +# See lindsys.icn for documentation about format. +# +# See linden.dat for an example of input data. +# +# See also linden.icn for a graphics version. +# +############################################################################ + +record Lsys(name, axiom, gener, angle, comment, productions) + +procedure makelsys(lst) #: make L-system from list + local line, i, s, c, symbol, rewrite + local allchars, rhs, value, spec, result + + result := Lsys() + + rewrite := table() + allchars := '' # cset of all rhs characters + + while line := get(lst) do { + line ? { + if symbol := move(1) & ="->" then { + rhs := tab(0) + rewrite[symbol] := rhs + allchars ++:= rhs # keep track of all characters + } + else if spec := tab(upto(':')) then { + move(1) + value := tab(0) + if spec == "axiom" then allchars ++:= value + else if spec == "end" then break + /result[spec] := value + } + } + } + +# At this point, we have the table to map characters, but it may lack +# mappings for characters that "go into themselves" by default. For +# efficiency in rewriting, these mappings are added. + + every c := !allchars do + /rewrite[c] := c + + result.productions := rewrite + + return result + +end + +procedure readlsys(input) #: make L-system from a file + local result + + result := [] + + while put(result, read(input)) + + return makelsys(result) + +end diff --git a/ipl/procs/mapbit.icn b/ipl/procs/mapbit.icn new file mode 100644 index 0000000..86286b3 --- /dev/null +++ b/ipl/procs/mapbit.icn @@ -0,0 +1,57 @@ +############################################################################ +# +# File: mapbit.icn +# +# Subject: Procedures to map string into bit representation +# +# Author: Ralph E. Griswold +# +# Date: December 5, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# The procedure mapbit(s) produces a string of zeros and ones +# corresponding to the bit patterns for the characters of s. For +# example, mapbit("Axe") produces "010000010111100001100101". +# +############################################################################ +# +# Links: strings +# +############################################################################ + +link strings + +procedure bilit(text,alpha,first,second) + return collate(map(text,alpha,first),map(text,alpha,second)) +end + +procedure mapbit(s) + static all, base16, hex1, hex2, quad1, quad2, pair1, pair2 + + # The following is a bit ornate, but then ... . It could be + # made more compact (and cryptic) by using lists of templates + # and parameterizing the initialization. + + initial { + all := string(&cset) + base16 := "0123456789ABCDEF" + hex1 := "" + every hex1 ||:= repl(!base16,16) + hex2 := repl(base16,16) + quad1 := "" + every quad1 ||:= repl(!left(base16,4),4) + quad2 := repl(left(base16,4),4) + pair1 := "" + every pair1 ||:= repl(!left(base16,2),2) + pair2 := repl(left(base16,2),2) + } + + s := bilit(bilit(bilit(s,all,hex1,hex2),base16,quad1,quad2),left(base16,4), + pair1,pair2) + return s +end diff --git a/ipl/procs/mapstr.icn b/ipl/procs/mapstr.icn new file mode 100644 index 0000000..3ba7059 --- /dev/null +++ b/ipl/procs/mapstr.icn @@ -0,0 +1,74 @@ +############################################################################ +# +# File: mapstr.icn +# +# Subject: Procedure for map() for strings +# +# Author: Richard L. Goerwitz +# +# Date: March 3, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.1 +# +############################################################################ +# +# Mapstrs(s, l1, l2) works like map(), except that instead of taking +# ordered character sequences (strings) as arguments 2 and 3, it +# takes ordered string sequences (lists). +# +# Suppose, for example, you wanted to bowdlerize a string by +# replacing the words "hell" and "shit" with "heck" and "shoot." You +# would call mapstrs as follows: +# +# mapstrs(s, ["hell", "shit"], ["heck", "shoot"]) +# +# In order to achieve reasonable speed, mapstrs creates a lot of +# static structures, and uses some extra storage. If you want to +# replace one string with another, it is overkill. Just use the IPL +# replace() routine (in strings.icn). +# +# If l2 is longer than l1, extra members in l2 are ignored. If l1 is +# longer, however, strings in l1 that have no correspondent in l2 are +# simply deleted. Mapstr uses a longest-possible-match approach, so +# that replacing ["hellish", "hell"] with ["heckish", "heck"] will +# work as one would expect. +# +############################################################################ +# +# Links: longstr +# +############################################################################ + +link longstr + +procedure mapstrs(s, l1, l2) + + local i, s2 + static cs, tbl, last_l1, last_l2 + + if /l1 | *l1 = 0 then return s + + if not (last_l1 === l1, last_l2 === l2) then { + cs := '' + every cs ++:= (!l1)[1] + tbl := table() + every i := 1 to *l1 do + insert(tbl, l1[i], (\l2)[i] | "") + } + + s2 := "" + s ? { + while s2 ||:= tab(upto(cs)) do + s2 ||:= tbl[tab(longstr(l1))] | move(1) + s2 ||:= tab(0) + } + + return s2 + +end diff --git a/ipl/procs/matchlib.icn b/ipl/procs/matchlib.icn new file mode 100644 index 0000000..268ccf8 --- /dev/null +++ b/ipl/procs/matchlib.icn @@ -0,0 +1,60 @@ +############################################################################ +# +# File: matchlib.icn +# +# Subject: Procedures for lexical matching +# +# Author: Ralph E. Griswold +# +# Date: September 2, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures perform low-level "lexical" matching for +# recursive-descent pattern matchers. +# +# rb_() match right bracket +# lb_() match left bracket +# rp_() match right parenthesis +# lp_() match left parenthesis +# vb_() match vertical bar +# nl_() match newline +# empty_() match empty string +# +############################################################################ +# +# See also: parsgen.icn +# +############################################################################ + +procedure rb_() + suspend =">" +end + +procedure lb_() + suspend ="<" +end + +procedure rp_() + suspend =")" +end + +procedure lp_() + suspend =")" +end + +procedure vb_() + suspend ="|" +end + +procedure nl_() + suspend ="\n" +end + +procedure empty_() + suspend "" +end diff --git a/ipl/procs/math.icn b/ipl/procs/math.icn new file mode 100644 index 0000000..cb36ff2 --- /dev/null +++ b/ipl/procs/math.icn @@ -0,0 +1,69 @@ +############################################################################ +# +# File: math.icn +# +# Subject: Procedures for mathematical computations +# +# Author: Ralph E. Griswold +# +# Date: December 26, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# binocoef(n, k) produces the binomial coefficient n over k. It +# fails unless 0 <= k <= n. +# +# cosh(r) produces the hyperbolic cosine of r. +# +# sinh(r) produces the hyperbolic sine of r. +# +# tanh(r) produces the hyperbolic tangent of r. +# +# +############################################################################ +# +# Requires: Large integer arithmetic for binocoef(n, k) for all but small +# values of n and k. +# +############################################################################ +# +# Links: factors +# +############################################################################ + +link factors + +procedure binocoef(n, k) #: binomial coefficient + + k := integer(k) | fail + n := integer(n) | fail + + if (k = 0) | (n = k) then return 1 + + if 0 <= k <= n then + return factorial(n) / (factorial(k) * factorial(n - k)) + else fail + +end + +procedure cosh(r) #: hyperbolic cosine + + return (&e ^ r + &e ^ -r) / 2 + +end + +procedure sinh(r) #: hyperbolic sine + + return (&e ^ r - &e ^ -r) / 2 + +end + +procedure tanh(r) #: hyperbolic tanh + + return (&e ^ r - &e ^ -r) / (&e ^ r + &e ^ -r) + +end diff --git a/ipl/procs/matrix.icn b/ipl/procs/matrix.icn new file mode 100644 index 0000000..48007c4 --- /dev/null +++ b/ipl/procs/matrix.icn @@ -0,0 +1,183 @@ +############################################################################ +# +# File: matrix.icn +# +# Subject: Procedures for matrix manipulation +# +# Authors: Stephen B. Wampler and Ralph E. Griswold +# +# Date: December 2, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This file contains procedures for matrix manipulation. +# +############################################################################ +# +# Links: lu +# +############################################################################ + +link lu + +procedure matrix_width(M) + + return *M[1] + +end + +procedure matrix_height(M) + + return *M + +end + +procedure write_matrix(file, M, x, s) + local r, c, row, col + + r := matrix_height(M) + c := matrix_width(M) + + if /x then { # packed, no punctuation + every row := 1 to r do { + every col := 1 to c do { + writes(file, M[row][col], s) + } + write(file) + } + } + else { + every row := 1 to r do { + writes(file, "[") + every col := 1 to c do { + writes(file, M[row][col], ", ") + } + write(file, "]") + } + } + +end + +procedure copy_matrix(M) + local M1, n, i + + n := *M + + M1 := list(n) + + every i := 1 to n do + M1[i] := copy(M[i]) + + return M1 + +end + +procedure create_matrix(n, m, x) + local M + + M := list(n) + every !M := list(m, x) + + return M + +end + +procedure identity_matrix(n, m) + local r, c, M + + M := create_matrix(n, m, 0) + + every r := 1 to n do { + every c := 1 to m do { + if r = c then M[r][c] := 1 + } + } + + return M + +end + +procedure add_matrix(M1, M2) + local M3, r, c, n, m + + if ((n := *M1) ~= *M2) | ((m := *M1[1]) ~= *M2[1]) then + stop("*** incorrect matrix sizes") + + M3 := create_matrix(n, m) + + every r := 1 to n do + every c := 1 to m do + M3[r][c] := M1[r][c] + M2[r][c] + + return M3 + +end + +procedure mult_matrix(M1, M2) + local M3, r, c, n, k + + if (n := *M1[1]) ~= *M2 then stop("*** incorrect matrix sizes") + + M3 := create_matrix(*M1,*M2[1]) + every r := 1 to *M1 do { + every c := 1 to *M2[1] do { + M3[r][c] := 0 + every k := 1 to n do { + M3[r][c] +:= M1[r][k] * M2[k][c] + } + } + } + + return M3 + +end + +procedure invert_matrix(M) + local M1, Y, I, d, i, n, B, j + + n := *M + if n ~= *M[1] then stop("*** matrix not square") + + M1 := copy_matrix(M) + Y := identity_matrix(n, n) + I := list(n, 0) # index vector + +# First perform LH decomposition on M1 (which changes it and produces +# an index vector, I. + + d := lu_decomp(M1, I) | stop("*** singular matrix") + + every j := 1 to n do { + B := list(n) # work on columns + every i := 1 to n do + B[i] := Y[i][j] + lu_back_sub(M1, I, B) # does not change M1 or I + every i := 1 to n do # put column in result + Y[i][j] := B[i] + } + + return Y + +end + +procedure determinant(M) + local M1, I, result, i, n + + n := *M + if n ~= *M[1] then stop("*** matrix not square") + + M1 := copy_matrix(M) + I := list(n, 0) # not used but required by lu_decomp() + + result := lu_decomp(M1, I) | stop("*** singular matrix") + + every i := 1 to n do # determinant is produce of diagonal + result *:= M1[i][i] # elements of the decomposed matrix + + return result + +end diff --git a/ipl/procs/matrix2.icn b/ipl/procs/matrix2.icn new file mode 100644 index 0000000..cf64a89 --- /dev/null +++ b/ipl/procs/matrix2.icn @@ -0,0 +1,301 @@ +############################################################################ +# +# File: matrix2.icn +# +# Subject: Procedures for matrix transposition and scalar multiplication +# +# Authors: Arthur C. Eschenlauer +# +# Date: November 1, 2005 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# transpose_matrix(M) : L - produces a matrix R that is the transpose of M: +# R[j][i] = M[i][j] +# +# numeric_matrix(M) : L - produces a matrix R that is a copy of M except +# each element has been subjected to the +# numeric(x) function; if numeric fails for any +# element, numeric_matrix fails: +# R[i][j] = numeric(M[i][j]) +# +# scale_matrix(M,mult) : L - produces a new matrix R each of whose elements +# is mult times larger than its peer in M: +# R[i][j] := mult * M[i][j] +# scale_matrix(mult,M) : L - is a synonym for scale_matrix(M,mult). +# +# floor_matrix(M,min) : L - produces a matrix R that is a copy of M except +# each element is increased to min if necessary: +# R[i][j] := min <= M[i][j] | min +# floor_matrix(min,M) : L - is a synonym for floor_matrix(M,min). +# +# ceil_matrix(M,max) : L - produces a matrix R that is a copy of M except +# each element is increased to max if necessary: +# R[i][j] := max <= M[i][j] | max +# ceil_matrix(max,M) : L - is a synonym for ceil_matrix(M,max). +# +# sumsquares_matrix(M) : n - produces the sum of the squares +# of all terms in a matrix +# sum(for every i,j) (M[i][j])^2 +# +# sumsquaresdiff_matrix(M1,M2) : n - produces the sum of the squares of all +# terms in the difference between two matrices +# sum(for every i,j) (M1[i][j] - M2[i][j])^2 +# +# normalize_rows(M,t) : L - produce a row-scaled matrix such that, +# for every row i, the sum of the values in +# all columns is 1 +# R[i][j] /:= sum(for every J) M[i][J] +# t is a required minimum magnitude +# for row sums to avoid divide-by-zero errors +# normalize_rows(t,M) : L - synonym for normalize_rows(M,t) +# +# normalize_columns(M,t) : L - produce a column-scaled matrix such that, +# for every column i, the sum of the values +# in all rows is 1 +# such that their sum is 1 +# R[i][j] /:= sum(for every I) M[I][j] +# t is a required minimum magnitude for +# column sums to avoid divide-by-zero errors +# normalize_columns(t,M) : L - synonym for normalize_columns(M,t) +# +# sprintf_matrix(f,M) - produces a matrix R of strings whose elements +# are formatted (by the IPL sprintf routine) +# from the elements of M: +# R[i][j] := sprintf(f,M[i,j]) +# +############################################################################ +# +# Links: matrix, printf +# +############################################################################ + +link matrix +link printf + +# transpose_matrix(M) - produces a new matrix R that is the transpose of M: +# R[j][i] = M[i][j] +procedure transpose_matrix(M) + local R, row, rowcnt, colcnt, i, j + # sanity checks + type(M) == "list" | fail + type(M[1]) == "list" | fail + rowcnt := *M | fail + colcnt := *M[1] | fail + every i := 2 to rowcnt + do *M[i] = colcnt | fail + R := list( ) # create list of rows + every i := 1 to colcnt do { + put( R, row := list( ) ) # create list of column values + every j := 1 to rowcnt do # populate column values + put( row, M[j][i] ) + } + return R +end + +# numeric_matrix(M) - produces a new matrix R that is a copy of M except +# each element has been subjected to the numeric(x) +# function; if numeric fails for any element, +# numeric_matrix fails: +# R[i][j] = numeric(M[i][j]) +procedure numeric_matrix(M) + local R, row, rowcnt, colcnt, i, j + # sanity checks + type(M) == "list" | fail + type(M[1]) == "list" | fail + rowcnt := *M | fail + colcnt := *M[1] | fail + every i := 2 to rowcnt + do *M[i] = colcnt | fail + R := list( ) # create list of rows + every i := 1 to rowcnt do { + put( R, row := list( ) ) # create list of column values + every j := 1 to colcnt do # populate column values + put( row, numeric(M[i][j]) | fail ) + } + return R +end + +# scale_matrix(M,mult) - produces a new matrix R each of whose elements is +# mult times larger than its peer in M: +# R[i][j] := mult * M[i][j] +# scale_matrix(mult,M) - is a synonym for scale_matrix(M,mult). +procedure scale_matrix(mult,M) + local R, i, j + # handle synonymous invocation + if numeric(M) & type(mult) == "list" then M :=: mult + # sanity checks + mult := numeric(mult) | fail + type(M) == "list" | fail + type(M[1]) == "list" | fail + R := copy_matrix(M) | fail # create a copy of input matrix + every i := 1 to *R do # for each row + every j := 1 to *R[1] do # for each column + # scale the column value + R[i][j] := numeric(R[i][j]) * mult | fail + return R +end + +# floor_matrix(M,min) - produces a new matrix R that is a copy of M except +# each element is increased to min if necessary: +# R[i][j] := min <= M[i][j] | min +procedure floor_matrix(min,M) + local R, i, j, r + # handle synonymous invocation + if numeric(M) & type(min) == "list" then M :=: min + # sanity checks + min := numeric(min) | fail + type(M) == "list" | fail + type(M[1]) == "list" | fail + R := copy_matrix(M) | fail # create copy of input matrix + every i := 1 to *R do # for each row + every j := 1 to *R[1] do { # for each column + # adjust column value if less than min + r := numeric(R[i][j]) | fail + R[i][j] := r < min | r + } + return R +end +# floor_matrix(min,M) - is a synonym for floor_matrix(M,min). + +# ceil_matrix(M,max) - produces a new matrix R that is a copy of M except +# each element is increased to max if necessary: +# R[i][j] := max <= M[i][j] | max +procedure ceil_matrix(max,M) + local R, i, j, r + # handle synonymous invocation + if numeric(M) & type(max) == "list" then M :=: max + # sanity checks + max := numeric(max) | fail + type(M) == "list" | fail + type(M[1]) == "list" | fail + R := copy_matrix(M) | fail # create copy of input matrix + every i := 1 to *R do # for each row + every j := 1 to *R[1] do { # for each column + # adjust column value if less than max + r := numeric(R[i][j]) | fail + R[i][j] := r > max | r + } + return R +end +# ceil_matrix(max,M) - is a synonym for ceil_matrix(M,max). + +# sumsquares_matrix(M) - produces the sum of the squares +# of all terms in a matrix +# sum( for every i,j ) (M[i][j])^2 +procedure sumsquares_matrix(M) + local r, r1, i, j + # sanity checks + type(M) == "list" | fail + type(M[1]) == "list" | fail + # compute the sum of squares + r := 0 + every i := 1 to *M do # for each row + every j := 1 to *M[1] do { # for each column + # sumsquare the column value + r1 := M[i][j] + r +:= r1 * r1 + } + return r +end + +# sumsquaresdiff_matrix(M1,M2) - produces the sum of the squares +# of all terms in the difference between two matrices +# sum( for every i,j ) (M1[i][j] - M2[i][j])^2 +procedure sumsquaresdiff_matrix(M1,M2) + local r, r1, r2, i, j, scratch + # sanity checks + type(M1) == type(M2) == "list" | fail + type(M1[1]) == type(M2[1]) == "list" | fail + ( *M1 = *M2, *M1[1] = *M2[1] ) | fail + # compute the sum of squares + r := 0 + every i := 1 to *M1 do # for each row + every j := 1 to *M1[1] do { # for each column + # sumsquare the column value + r1 := M1[i][j] ; r2 := r1 - M2[i][j] + r +:= r2 * r2 + } + return r +end + +# normalize_rows(M,t) : L - produce a row-scaled matrix such that, +# for every row i, the sum of the values in +# all columns is 1 +# R[i][j] /:= sum(for every J) M[i][J] +# t is a required minimum magnitude +# for row sums to avoid divide-by-zero errors +# normalize_rows(t,M) : L - synonym for normalize_rows(M,t) +procedure normalize_rows(M,threshold) + local R, rowsum, rowcnt, colcnt, i, j + # handle synonymous invocation + if numeric(M) & type(threshold) == "list" then M :=: threshold + # sanity checks + type(M) == "list" | fail + type(M[1]) == "list" | fail + \threshold | fail + R := copy_matrix( M ) | fail + rowcnt := *R + colcnt := *R[1] + every i := 1 to rowcnt do { # for each column + rowsum := 0 + every j := 1 to colcnt do rowsum +:= R[i][j] + if not -threshold < rowsum < threshold + then + every j := 1 to colcnt do R[i][j] /:= rowsum + } + return R +end + +# normalize_columns(M,t) : L - produce a column-scaled matrix such that, +# for every column i, the sum of the values +# in all rows is 1 +# such that their sum is 1 +# R[i][j] /:= sum(for every I) M[I][j] +# t is a required minimum magnitude for +# column sums to avoid divide-by-zero errors +# normalize_columns(t,M) : L - synonym for normalize_columns(M,T) +procedure normalize_columns(M,threshold) + local R, colsum, rowcnt, colcnt, i, j + # handle synonymous invocation + if numeric(M) & type(threshold) == "list" then M :=: threshold + # sanity checks + type(M) == "list" | fail + type(M[1]) == "list" | fail + \threshold | fail + R := copy_matrix( M ) | fail + rowcnt := *R + colcnt := *R[1] + every j := 1 to colcnt do { # for each column + colsum := 0 + every i := 1 to rowcnt do colsum +:= R[i][j] + if not -threshold < colsum < threshold + then + every i := 1 to rowcnt do R[i][j] /:= colsum + } + return R +end + +# sprintf_matrix(format,M) - produces a matrix R of strings formatted +# by sprintf +procedure sprintf_matrix( fmt, M ) + local R, row, rowcnt, colcnt, i, j + # sanity checks + type(M) == "list" | fail + type(M[1]) == "list" | fail + rowcnt := *M | fail + colcnt := *M[1] | fail + every i := 2 to rowcnt + do *M[i] = colcnt | fail + R := list( ) # create list of rows + every i := 1 to rowcnt do { + put( R, row := list( ) ) # create list of column values + every j := 1 to colcnt do # populate column values + put( row, sprintf( fmt, M[i][j] ) | fail ) + } + return R +end diff --git a/ipl/procs/memlog.icn b/ipl/procs/memlog.icn new file mode 100644 index 0000000..0009816 --- /dev/null +++ b/ipl/procs/memlog.icn @@ -0,0 +1,42 @@ +############################################################################ +# +# File: memlog.icn +# +# Subject: Procedure to log memory usage +# +# Author: Gregg M. Townsend +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# memlog(f) writes a message to file f recording the current memory +# usage in the string and block regions. For each, three figures are +# written: amount in use, amount reserved, and number of collections. +# +# memlog does not perturb the figures: it requires no allocation itself. +# f defaults to &output. memlog() returns the total current usage. +# +############################################################################ + +procedure memlog(f) #: log memory usage + local sused, bused, salloc, balloc, scoll, bcoll + + every sused := &storage \ 2 + every bused := &storage \ 3 + + every salloc := ®ions \ 2 + every balloc := ®ions \ 3 + + every scoll := &collections \ 3 + every bcoll := &collections \ 4 + + write(f, "str:", sused, "/", salloc, "(", scoll, ") ", + "blk:", bused, "/", balloc, "(", bcoll, ") ") + return sused + bused +end + diff --git a/ipl/procs/memrfncs.icn b/ipl/procs/memrfncs.icn new file mode 100644 index 0000000..bb54c17 --- /dev/null +++ b/ipl/procs/memrfncs.icn @@ -0,0 +1,71 @@ +############################################################################ +# +# File: memrfncs.icn +# +# Subject: Procedures for recursive functions using memory +# +# Author: Ralph E. Griswold +# +# Date: February 4, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures implement commonly referenced ``text-book'' +# recursively defined functions using memory to avoid redundant calls. +# +# acker(i, j) Ackermann's function +# fib(i) Fibonacci sequence +# q(i) "Chaotic" sequence +# +############################################################################ +# +# See also: fastfncs, iterfncs.icn, and recrfncs.icn +# +############################################################################ + +procedure acker(i, j) + static memory + + initial { + memory := table() + every memory[0 to 100] := table() + } + + if i = 0 then return j + 1 + + if j = 0 then /memory[i][j] := acker(i - 1, 1) + else /memory[i][j] := acker(i - 1, acker(i, j - 1)) + + return memory[i][j] + +end + +procedure fib(i) + static memory + + initial { + memory := table() + memory[1] := memory[2] := 1 + } + + /memory[i] := fib(i - 1) + fib(i - 2) + return memory[i] + +end + +procedure q(i) + static memory + + initial { + memory := table() + memory[1] := memory[2] := 1 + } + + /memory[i] := q(i - q(i - 1)) + q(i - q(i - 2)) + return memory[i] + +end diff --git a/ipl/procs/mixsort.icn b/ipl/procs/mixsort.icn new file mode 100644 index 0000000..47c9406 --- /dev/null +++ b/ipl/procs/mixsort.icn @@ -0,0 +1,61 @@ +############################################################################ +# +# File: mixsort.icn +# +# Subject: Procedure to sort tables with case mixing +# +# Author: Ralph E. Griswold +# +# Date: August 30, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure sorts tables like sort(T, i), except that the keys +# that are strings are sorted with case mixed. That is, keys such +# as "Volvo" and "voluntary" come out sorted "voluntary" followed by +# "Volvo" as if it were "volvo" instead (assuming ASCII). +# +# If a string appears in two case forms, as in "Volvo" and "volvo", one key +# is lost. +# +# At present, this procedure applies only to keys (i = 1 or 3). It could +# be extended to handle values (i = 2 or 3). +# +############################################################################ + +procedure mixsort(T, i) #: mixed-case string sorting + local xcase, x, y, temp, j + + xcase := table() # key-mapping table + temp := table() # parallel table + + if i = (2 | 4) then return sort(T, i) # doesn't apply + # (could do values ...) + + every x := key(T) do { # map keys + if type(x) == "string" then y := map(x) # only transform strings + else y := x + temp[y] := T[x] # lowercase table + xcase[y] := x # key mapping + } + + temp := sort(temp, i) # basic sort on lowercase table + + if i = 3 then { + every j := 1 to *temp - 1 by 2 do + temp[j] := xcase[temp[j]] + } + else if i === (1 | &null) then { + every x := !temp do + x[1] := xcase[x[1]] + } + + else return sort(T, i) # error, but pass the buck + + return temp + +end diff --git a/ipl/procs/models.icn b/ipl/procs/models.icn new file mode 100644 index 0000000..9de30fe --- /dev/null +++ b/ipl/procs/models.icn @@ -0,0 +1,116 @@ +############################################################################ +# +# File: models.icn +# +# Subject: Procedure to model Icon functions +# +# Author: Ralph E. Griswold +# +# Date: May 1, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures model built-in Icon functions. Their purpose is +# primarily pedagogical. +# +# See Icon Analyst 11, pp. 5-7. +# +############################################################################ + +procedure tab(i) + + suspend .&subject[.&pos : &pos <- i] + +end + +procedure upto(c, s, i, j) + local k + + if /s := &subject then { # handle defaults + /i := &pos + } + else { + s := string(s) | runerr(103, s) + /i := 1 + } + + i := integer(i) | runerr(101, i) + i := cvpos(i, s) | fail + + if not(/j := *s + 1) then { + j := integer(j) | runerr(101, j) + j := cvpos(j, s) | fail + if i > j then i :=: j + } + + every k := i to j do + if !c == s[k] then suspend k # perform the actual mapping + +# The following is faster, but not as clear. +# +# every k := i to j do +# if any(c, s[k]) then suspend k + + fail + +end + +procedure map(s1, s2, s3) + local i, result + static last_s2, last_s3, map_array + + initial map_array := list(256) + + s1 := string(s1) | runerr(103, s1) # check types + s2 := def_str(s2, string(&ucase)) | runerr(103, s2) # default null values + s3 := def_str(s3, string(&lcase)) | runerr(103, s3) + if *s2 ~= *s3 then runerr(208) + +# See if mapping array needs to be rebuilt + + if (s2 ~=== last_s2) | (s3 ~=== last_s3) then { + last_s2 := s2 + last_s3 := s3 + + every i := 1 to 256 do + map_array[i] := char(i - 1) + + every i := 1 to *s2 do + map_array[ord(s2[i]) + 1] := s3[i] + } + + result := "" + +# every result ||:= map_array[ord(!s1) + 1] # do actual mapping + + every i := 1 to *s1 do # do actual mapping + result ||:= map_array[ord(s1[i]) + 1] + + return result + +end + +# Support procedures + +# Produce the positive equivalent of i with respect to s. + +procedure cvpos(i, s) + + if i <= 0 then i +:= *s + 1 + if i <= i <= *s + 1 then return i + else fail + +end + +# Default the null value to a specified string. + +procedure def_str(s1, s2) + + if /s1 then return s2 + else return string(s1) # may fail + +end diff --git a/ipl/procs/morse.icn b/ipl/procs/morse.icn new file mode 100644 index 0000000..1485c9b --- /dev/null +++ b/ipl/procs/morse.icn @@ -0,0 +1,50 @@ +############################################################################ +# +# File: morse.icn +# +# Subject: Procedures to convert string to Morse code +# +# Author: Ralph E. Griswold, modified by Rich Morin +# +# Date: June 26, 1990 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure converts the string s to its Morse code equivalent. +# +# The version used is known both as International Morse Code and as +# Continental Code, and is used by radio amateurs (hams). +# +############################################################################ + +procedure morse(s) + local i, c, t, x + static code, key1, key2 + + initial { + code := "....------.----..---.-.---...--.--._ + -..--..-.--....-.-.-...-..-....." + key1 := "tmot09ttt1t8tt2gqtttjtz7t3nky(tcttt_ + tdx/twptb64earttltvtiuftsh5" + key2 := "tttttttttt'tt,ttttttttt:tttttt)tttt_ + t?tttttttt-ttt.;tttttt\"tttt" + } + + x := "" + every c := !map(s) do + if i := upto(c, key1) then { + t := code[i+:6] + x ||:= t[ upto("-",t)+1 : 0 ] || " " + } + else if i := upto(c, key2) then + x ||:= code[i+:6] || " " + else if c == " " then + x ||:= " " + else + x ||:= "<" || c || "> " + return x +end diff --git a/ipl/procs/mset.icn b/ipl/procs/mset.icn new file mode 100644 index 0000000..db9dc75 --- /dev/null +++ b/ipl/procs/mset.icn @@ -0,0 +1,111 @@ +############################################################################ +# +# File: mset.icn +# +# Subject: Procedures for multi-sets +# +# Author: Jan P. de Ruiter +# +# Date: January 3, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# The idea of the mset type is that no two identical data-structures can be +# present in a set, where identity is defined as "containing the same +# elements". +# +# Definitions implicit in the procedure same_value(..,..): +# +# TYPE IDENTITY TEST +# +# all types === and if this test fails... +# +# integer = +# real = +# cset, string == +# record all fields have same value +# list all elements are the same, including ordering +# table same keys, and every key has the same associated value +# set contain the same elements +# +############################################################################ + +# +# This is the core routine. +# It succeeds if two things have the same value(s). +# +procedure same_value(d1,d2) + if d1 === d2 then return # same object + else + if type(d1) ~== type(d2) then fail # not the same type + else + if *d1 ~= *d2 then fail # not the same size + else + case type(d1) of { # the same type and size + ("set" | "table" ) : return same_elements(sort(d1,1),sort(d2,1)) + ("list") : return same_elements(d1,d2) + ("real" | "integer") : return(d1 = d2) + ("cset" | "string" ) : return(d1 == d2) + default : return same_elements(d1,d2) # user defined type + } +end + +# +# used in same_value: +# + +procedure same_elements(l1,l2) + local i + if l1 === l2 then return # same objects + else + if *l1 ~= *l2 then fail # not the same size + else { + if *l1 = 0 then return # both lists empty + else { + every(i := 1 to *l1) do + if not same_value(l1[i],l2[i]) then fail # recursion + return + } + } +end + +# +# The new insert operation. Insert2 always succeeds +# +procedure insert2(S,el) + every (if same_value(el,!S) then return) + return insert(S,el) +end + +# +# The new member operation, that also detects equal-valued elements +# +procedure member2(S,el) + every(if same_value(!S,el) then return) + fail +end + +# +# The new delete operation, that detects equal-valued elements. +# Always succeeds +# +procedure delete2(S,el) + local t + every(t := !S) do if same_value(t,el) then return delete(S,t) + return +end + +# +# conversion of standard icon set into new mset. +# +procedure reduce2(iset) + local temp + temp := set() + every(insert2(temp,!iset)) + return temp +end + diff --git a/ipl/procs/namepfx.icn b/ipl/procs/namepfx.icn new file mode 100644 index 0000000..43bc9ce --- /dev/null +++ b/ipl/procs/namepfx.icn @@ -0,0 +1,46 @@ +############################################################################ +# +# File: namepfx.icn +# +# Subject: Procedure to produce prefix portion of name +# +# Author: Ralph E. Griswold +# +# Date: September 2, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Produces the "name prefix" from a name in standard form -- omitting +# any title, but picking up the first name and any initials. +# +# There are a lot more titles that should be added to this list. +# +# Obviously, it can't always produce the "correct" result. +# +############################################################################ +# +# Links: lastname, titleset +# +############################################################################ + +link lastname, titleset + +procedure namepfx(s) + static titles + + initial titles := titleset() + + s ?:= { # Get past title + while =!titles do tab(many(' ')) # "Professor Doctor ... " + tab(0) + } + + s ?:= trim(tab(find(lastname(s)))) + + return s + +end diff --git a/ipl/procs/nestlist.icn b/ipl/procs/nestlist.icn new file mode 100644 index 0000000..7304706 --- /dev/null +++ b/ipl/procs/nestlist.icn @@ -0,0 +1,73 @@ +############################################################################ +# +# File: nestlist.icn +# +# Subject: Procedures to interconvert strings and nested lists +# +# Author: Arthur C. Eschenlauer +# +# Date: November 1, 2005 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Procedure s_list(L) produces a string-representation of a nested +# list. +# +# Procedure l_list(s) produces a nested list from s, its string +# representation. +# +############################################################################ +# +# # demo for reading nested numeric array from a string, e.g., +# # [1,[2,3,[4]],[[5]]] +# procedure main( ) +# local line, m, i +# while line := read( ) +# do +# if m := l_list( line ) +# then write( s_list( m ) ) +# end +# +############################################################################ + +# s_list - produce a string from a nested list +procedure s_list( L ) + local i, s + if type( L ) ~== "list" + then return string( L ) + s := "[" + every i := 1 to *L + do s ||:= ( if i ~= 1 then "," else "" ) || s_list( L[i] ) + return s || "]" +end + +# l_list - produce a nested list from a string +# l_list( ) ::= l_listall( ) pos(0) +# l_listall( ) ::= ="[" l_terms( ) ="]" +# l_terms( ) ::= l_term( ) ="," l_terms( ) | l_term( ) +# l_term( ) ::= l_listall( ) | tab(many(&cset--'[,]')) + +procedure l_list( s ) + s ? return 1(l_listall( ), pos(0)) +end + +procedure l_listall( ) + every suspend 2( ="[", l_terms( ), ="]" ) +end + +procedure l_terms( ) + local a1, a2 + every suspend 4( a1:=l_term( ) , ="," + , a2:=l_terms( ), a1 ||| a2 ) | + l_term( ) +end + +procedure l_term( ) + static noend, convert + initial noend := &cset -- '[,]' + suspend [ l_listall( ) | tab( many( noend ) ) ] +end diff --git a/ipl/procs/ngrams.icn b/ipl/procs/ngrams.icn new file mode 100644 index 0000000..6de13c3 --- /dev/null +++ b/ipl/procs/ngrams.icn @@ -0,0 +1,80 @@ +############################################################################ +# +# File: ngrams.icn +# +# Subject: Procedures to produce n-grams +# +# Author: Ralph E. Griswold +# +# Date: March 20, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# The procedure ngrams(s, n, c, t) generates a tabulation of the n-grams +# in the specified string. If c is non-null, it is used as the set of +# characters from which n-grams are taken (other characters break n-grams). +# The default for c is the upper- and lowercase letters. If t is non-null, +# the tabulation is given in order of frequency; otherwise in alphabetical +# order of n-grams. +# +# For backward compatibility, the first argument may be a file, in +# which case, it is read to provide the string. +# +############################################################################ + +procedure ngrams(s, i, c, t) #: n-grams with count + local line, grams, a, count, f + + if not (integer(i) > 0) then stop("*** invalid ngrams specification") + + /c := &lcase || &ucase + if not (c := cset(c)) then stop("*** invalid cset specification") + + grams := table(0) + + if type(s) == "file" then { + line := "" + while line ||:= reads(f, 1000) + } + else line := s + line ? while tab(upto(c)) do + (tab(many(c)) \ 1) ? while grams[move(i)] +:= 1 do + move(-i + 1) + if /t then { + a := sort(grams, 4) + while count := pull(a) do + suspend pull(a) || right(count, 8) + } + else { + a := sort(grams, 3) + suspend |(get(a) || right(get(a),8)) + } +end + +procedure ngramset(s, i, c) #: n-grams set + local line, grams, a, count, f + + if not (integer(i) > 0) then stop("*** invalid ngrams specification") + + /c := &lcase || &ucase + if not (c := cset(c)) then stop("*** invalid cset specification") + + grams := set() + + if type(s) == "file" then { + line := "" + while line ||:= reads(f, 1000) + } + else line := s + + line ? while tab(upto(c)) do + (tab(many(c)) \ 1) ? while insert(grams, move(i)) do + move(-i + 1) + + return grams + +end diff --git a/ipl/procs/noncase.icn b/ipl/procs/noncase.icn new file mode 100644 index 0000000..4a60dec --- /dev/null +++ b/ipl/procs/noncase.icn @@ -0,0 +1,56 @@ +############################################################################ +# +# File: noncase.icn +# +# Subject: Procedures for case-independent matching +# +# Author: Robert J. Alexander +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Kit of case-independent versions of Icon's built-in string-analysis +# procedures. +# +############################################################################ + +procedure c_any(c,s,i1,i2) + return any(c_cset(c),s,i1,i2) +end + +procedure c_find(s1,s2,i1,i2) + local scanPos,endPos + scanPos := match("",s2,i1,i2) + endPos := many(&cset,s2,i1,i2) | scanPos + suspend scanPos - 1 + find(map(s1), + map((if \s2 then s2 else &subject)[scanPos:endPos])) +end + +procedure c_many(c,s,i1,i2) + return many(c_cset(c),s,i1,i2) +end + +procedure c_match(s1,s2,i1,i2) + local scanPos,endPos + scanPos := match("",s2,i1,i2) + endPos := scanPos + *s1 + return (map(s1) == map((if \s2 then s2 else &subject)[scanPos:endPos]),endPos) +end + +procedure c_upto(c,s,i1,i2) + suspend upto(c_cset(c),s,i1,i2) +end + +procedure c_cset(c) + static lstring,ustring + initial { + lstring := string(&lcase) + ustring := string(&ucase) + } + return cset(map(c) || map(c,lstring,ustring)) +end diff --git a/ipl/procs/numbers.icn b/ipl/procs/numbers.icn new file mode 100644 index 0000000..2823cf4 --- /dev/null +++ b/ipl/procs/numbers.icn @@ -0,0 +1,697 @@ +############################################################################ +# +# File: numbers.icn +# +# Subject: Procedures related to numbers +# +# Author: Ralph E. Griswold +# +# Date: June 10, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Contributors: Robert J. Alexander, Richard Goerwitz +# Tim Korb, and Gregg M. Townsend +# +############################################################################ +# +# These procedures deal with numbers in various ways: +# +# adp(i) additive digital persistence of i +# +# adr(i) additive digital root of i (same as digred()) +# +# amean ! L returns arithmetic mean of numbers in L. +# +# ceil(r) returns nearest integer to r away from 0. +# +# commas(s) inserts commas in s to separate digits into groups of +# three. +# +# decimal(i, j) decimal expansion of i / j; terminates when expansion +# terminates or the end of a recurring period is reached. +# The format of the returned value is <integer>.<seq>, +# where <seq> is a string a decimal digits if the +# expansion is finite but <pre>[<recurr>] if it +# is not, where <pre> is a string of decimal digits +# (possibly empty) before the recurring part. +# +# decipos(r, i, j) +# positions decimal point at i in real number r in +# field of width j. +# +# digprod(i) product of digits of i +# +# digred(i) reduction of number by adding digits until one digit is +# reached. +# +# digroot(i) same as digred(). +# +# digsum(i) sum of digits in i. +# +# distseq(i, j) generates i to j in distributed order. +# +# div(i, j) produces the result of real division of i by j. +# +# fix(i, j, w, d) formats i / j as a real (floating-point) number in +# a field of width w with d digits to the right of +# the decimal point, if possible. j defaults to 1, +# w to 8, and d to 3. If w is less than 3 it is set +# to 3. If d is less than 1, it is set to 1. The +# function fails if j is 0 or if the number cannot +# be formatted. +# +# floor(r) nearest integer to r toward 0. +# +# frn(r, w, d) format real number r into a string with d digits +# after the decimal point; a result narrower than w +# characters is padded on the left with spaces. +# Fixed format is always used; there is no exponential +# notation. Defaults: w 0, d 0 +# +# gcd(i, j) returns greatest common divisor of i and j. +# +# gcdl ! L returns the greatest common division of the integers +# list L. +# +# gmean ! L returns geometric mean of numbers in L. +# +# hmean ! L returns harmonic mean of numbers in L. +# +# large(i) succeeds if i is a large integer but fails otherwise. +# +# lcm(i, j) returns the least common multiple of i and j. +# +# lcml ! L returns the least common multiple of the integers +# in the list L. +# +# mantissa(r) mantissa (fractional part) of r. +# +# max ! L produces maximum of numbers in L. +# +# mdp(i) multiplicative digital persistence of i +# +# mdr(i) multiplicative digital root of i +# +# min ! L produces minimum of numbers in L. +# +# mod1(i, m) residue for 1-based indexing. +# +# npalins(n) generates palindromic n-digit numbers. +# +# residue(i, m, j) +# residue for j-based indexing. +# +# roman(i) converts i to Roman numerals. +# +# round(r) returns nearest integer to r. +# +# sigma(i) synonym for digroot(i) +# +# sign(r) returns sign of r. +# +# spell(i) spells out i in English. +# +# sum ! L sum of numbers in list L +# +# trunc(r) returns nearest integer to r toward 0 +# +# unroman(s) converts Roman numerals to integers. +# +############################################################################ +# +# Links: factors, strings +# +############################################################################ + +link factors +link strings + +procedure adp(i) #: additive digital persistence + local j + + j := 0 + + until *i = 1 do { + i := digsum(i) + j +:= 1 + } + + return j + +end + +procedure adr(i) #: additive digital root + + until *i = 1 do + i := digsum(i) + + return i + +end + +procedure amean(L[]) #: arithmetic mean + local m + + if *L = 0 then fail + + m := 0.0 + every m +:= !L + + return m / *L + +end + +procedure ceil(r) #: ceiling + + if integer(r) = r then return integer(r) + + if r > 0 then return integer(r) + 1 else return -(integer(-r) + 1) + +end + +procedure commas(s) #: insert commas in number + + local s2, sign + + # Don't bother if s is already comma-ized. + if type(s) == "string" & find(",", s) then fail + + # Take sign. Save chars after the decimal point (if present). + if s := abs(0 > s) + then sign := "-" else sign := "" + s ? { + s := tab(find(".")) & ="." & + not pos(0) & s2 := "." || tab(0) + } + + /s2 := "" + integer(s) ? { + tab(0) + while s2 := "," || move(-3) || s2 + if pos(1) + then s2 ?:= (move(1), tab(0)) + else s2 := tab(1) || s2 + } + + return sign || s2 + +end + +procedure decimal(i, j) #: decimal expansion of rational + local head, tail, numers, count + + head := (i / j) || "." + tail := "" + numers := table() + + i %:= j + count := 0 + + while i > 0 do { + numers[i] := count + i *:= 10 + tail ||:= i / j + i %:= j + if \numers[i] then # been here; done that + return head || (tail ? (move(numers[i]) || "[" || tab(0) || "]")) + count +:= 1 + } + + return head || tail + +end + +procedure decipos(r, i, j) #: position decimal point + local head, tail + + /i := 3 + /j := 5 + + r := real(r) | stop("*** non-numeric in decipos()") + + if i < 1 then fail + + r ? { + head := tab(upto('.eE')) | fail + move(1) + tail := tab(0) + return left(right(head, i - 1) || "." || tail, j) + } + +end + +procedure digred(i) #: sum digits of integer repeated to one digit + + digred := digroot + + return digred(i) + +end + +procedure digroot(i) #: digital root + + if i = 0 then return 1 + + i %:= 9 + + return if i = 0 then 9 else i + +end + +procedure digprod(i) #: product of digits + local j + + if upto('0', i) then return 0 + + else j := 1 + + every j *:= !i + + return j + +end + +procedure digsum(i) #: sum of digits + local j + + i := integer(i) | fail + + repeat { + j := 0 + every j +:= !i + suspend j + if *j > 1 then i := j else fail + } + +end + +# distseq() generates a range of integers in a deterministic order that is +# "most uniformly distributed" in Knuth's terminology (vol3, 1/e, p. 511). +# Each integer in the range is produced exactly once. + +procedure distseq(low, high) #: generate low to high nonsequentially + local n, start, incr, range + + low := integer(low) | runerr(101, low) + high := integer(high) | runerr(101, high) + if low > high then fail + range := high - low + 1 + start := n := range / 2 + + suspend low + n + + incr := integer(range / &phi ^ 2 + 0.5) + if incr <= 1 then + incr := 1 + else while gcd(incr, range) > 1 do + incr +:= 1 + + repeat { + n := (n + incr) % range + if n = start then fail + suspend low + n + } + +end + +procedure div(i, j) #: real division + + return i / real(j) + +end + +procedure fix(i, j, w, d) #: format real number + local r, int, dec, sign + + /j := 1 + /w := 8 + /d := 3 + if j = 0 then fail + w <:= 3 + d <:= 1 + r := real(i) / j + if r < 0 then { + r := -r + sign := "-" + } + else sign:="" + + int := dec := "0" # prepare for small number + + if not(r < ("0." || repl("0", d - 1) || "1")) then { # formats as zero + string(r) ? { + if upto('eE') then fail # can't format + if int := tab(find(".")) then { + move(1) + dec := tab(0) + } + } + } + + return right(sign || int || "." || left(dec, d, "0"), w) +end + +procedure floor(r) #: floor + + if r > 0 then return integer(r) else return -integer(-r) + +end + +$define MAXDECIMALS 25 + +procedure frn(r, w, d) #: format real number + + local s + static mlist + initial every put(mlist := list(), 10.0 ^ (0 to MAXDECIMALS)) + + r := real(r) | runerr(102, r) + (/d := 0) | (d >:= MAXDECIMALS) + if r >= 0.0 then { + s := string(integer(r * mlist[d + 1] + 0.5)) + s := right(s, *s < d + 1, "0") + } + else { + s := string(integer(-r * mlist[d + 1] + 0.5)) + s := right(s, *s < d + 1, "0") + s := "-" || s + } + s := right(s, *s < (\w - 1)) + + return s ? (tab(-d) || "." || tab(0)) + +end + +procedure gcd(i,j) #: greatest common divisor + local r + + if (i | j) < 1 then runerr(501) + + repeat { + r := i % j + if r = 0 then return j + i := j + j := r + } +end + +procedure gcdl(L[]) #: greatest common divisor of list + local i, j + + i := get(L) | fail + + while j := get(L) do + i := gcd(i, j) + + return i + +end + +procedure gmean(L[]) #: geometric mean + local m + + if *L = 0 then fail + + m := 1.0 + every m *:= !L + m := abs(m) + if m > 0.0 then + return exp (log(m) / *L) + else + fail +end + +procedure hmean(L[]) #: harmonic mean + local m, r + + if *L = 0 then fail + + m := 0.0 + + every r := !L do { + if r = 0.0 then fail + else m +:= 1.0 / r + } + + return *L / m + +end + +# +# At the source-language level, "native" integers and "large" +# integers have the same type, "integer". The creation of a large +# integer causes storage allocation, which this procedure detects. +# + +procedure large(i) #: detect large integers + local mem + + mem := &allocated + i +:= 0 + if &allocated > mem then return i + else fail + +end + +procedure lcm(i, j) #: least common multiple + + if (i = 0) | (j = 0) then return 0 # ??? + + return abs(i * j) / gcd(i, j) + +end + +procedure lcml(L[]) #: least common multiple of list + local i, j + + i := get(L) | fail + + while j := get(L) do + i := lcm(i, j) + + return i + +end + +procedure mantissa(r) #: mantissa (fractional part) + local fpart + + r := real(r) + + fpart := r - floor(r) + + fpart ?:= { + tab(upto('.') + 1) + tab(0) + } + + fpart ? { + if fpart := tab(upto('Ee')) then { + move(1) + if = "+" then fpart := "0" + else { + move(1) + fpart := repl("0", tab(0) - 1) || fpart + } + } + } + + return "." || fpart + +end + +procedure max(values[]) #: maximum value + local maximum + + maximum := get(values) | fail + every maximum <:= !values + + return maximum + +end + +procedure mdp(i) #: multiplicative digital persistence + local j + + j := 0 + + until *i = 1 do { + i := digprod(i) + j +:= 1 + } + + return j + +end + +procedure mdr(i) #: multiplicative digital root + + until *i = 1 do + i := digprod(i) + + return i + +end + +procedure min(values[]) #: minimum value + local minimum + + minimum := get(values) | fail + every minimum >:= !values + + return minimum + +end + +procedure mod1(i, m) #: modulus for 1-based integers + + i %:= m + + if i < 1 then i +:= m + + return i + +end + +procedure npalins(n) #: palindromic numbers + local i + + every i := palins(&digits, n) do + if i[1] ~== "0" then suspend i # can't start with zero + +end + +procedure residue(i, m, j) #: residue for j-based integers + + /j := 0 + + i %:= m + + if i < j then i +:= m + + return i + +end + +# This procedure is based on a SNOBOL4 function written by Jim Gimpel. +# +procedure roman(n) #: convert integer to Roman numeral + local arabic, result + static equiv + + initial equiv := ["","I","II","III","IV","V","VI","VII","VIII","IX"] + + integer(n) > 0 | fail + result := "" + every arabic := !n do + result := map(result,"IVXLCDM","XLCDM**") || equiv[arabic + 1] + if find("*",result) then fail else return result + +end + +procedure round(r) #: round real + + if r > 0 then return integer(r + 0.5) else return -integer(0.5 - r) + +end + +procedure sigma(i) #: synonym for digroot() + + sigma := digroot + + return sigma(i) + +end + +procedure sign(r) #: sign + + if r = 0 then return 0 + else if r < 0 then return -1 + else return 1 + +end + +procedure spell(n) #: spell out integer + local m + + n := integer(n) | stop(image(n)," is not an integer") + if n <= 12 then return { + "0zero,1one,2two,3three,4four,5five,6six,7seven,8eight,_ + 9nine,10ten,11eleven,12twelve," ? { + tab(find(n)) + move(*n) + tab(find(",")) + } + } + else if n <= 19 then return { + spell(n[2] || "0") ? + (if ="for" then "four" else tab(find("ty"))) || "teen" + } + else if n <= 99 then return { + "2twen,3thir,4for,5fif,6six,7seven,8eigh,9nine," ? { + tab(find(n[1])) + move(1) + tab(find(",")) || "ty" || + (if n[2] ~= 0 then "-" || spell(n[2]) else "") + } + } + else if n <= 999 then return { + spell(n[1]) || " hundred" || + (if (m := n[2:0]) ~= 0 then " and " || spell(m) else "") + } + else if n <= 999999 then return { + spell(n[1:-3]) || " thousand" || + (if (m := n[2:0]) ~= 0 then " and " || spell(m) else "") + } + else if n <= 999999999 then return { + spell(n[1:-6]) || " million" || + (if (m := n[2:0]) ~= 0 then " and " || spell(m) else "") + } + else fail + +end + +procedure sum(values[]) #: sum of numbers + local result + + result := 0 + + every result +:= !values + + return result + +end + +procedure trunc(r) #: truncate real + + return integer(r) + +end + +procedure unroman(s) #: convert Roman numeral to integer + local nbr,lastVal,val + + nbr := lastVal := 0 + + s ? { + while val := case map(move(1)) of { + "m": 1000 + "d": 500 + "c": 100 + "l": 50 + "x": 10 + "v": 5 + "i": 1 + } do { + nbr +:= if val <= lastVal then val else val - 2 * lastVal + lastVal := val + } + } + return nbr + +end diff --git a/ipl/procs/openchk.icn b/ipl/procs/openchk.icn new file mode 100644 index 0000000..0547638 --- /dev/null +++ b/ipl/procs/openchk.icn @@ -0,0 +1,113 @@ +############################################################################ +# +# File: openchk.icn +# +# Subject: Procedure to aid in open/close debugging +# +# Author: David A. Gamey +# +# Date: March 14, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Usage: +# +# OpenCheck() +# +# Subsequent opens and closes will write diagnostic information to &errout +# Useful for diagnosing situations where many files are opened and closed +# and there is a possibility that some files are not always being closed. +# +############################################################################# + +procedure OpenCheck(p,x) + +local f, e +static openS + +if type(p) == "procedure" then +{ + # Internal use, by intercept routines + + if /openS then + { + write(&errout,"OpenCheck has not been initialized.") + runerr(500) + } + + case p of + { + OpenCheck_open : + { + if ( f := p!x ) then + { + write( &errout, "Open of ", image(f), " succeeded." ) + insert( openS, f ) + } + else + { + writes( &errout, "Open of ") + every writes( &errout, image(!x) ) + write( &errout, " failed." ) + } + } + + OpenCheck_close: + { + e := 1 + &error :=: e + if ( f := p!x ) then + { + &error :=: e + write( &errout, "Close of ", image(f), " succeeded." ) + delete( openS, f ) + } + else + { + &error :=: e + write( &errout, "Close of ", image(f), " failed." ) + } + } + + default: + runerr(500) + } + + write( &errout, *openS, " objects are open:" ) + every write( &errout, " ", image(!sort( openS )) ) + + if type(f) == "file" then + return f + else + { + runerr(&errornumber,&errorvalue) # if error + fail + } +} +else +{ + # Setup call comes here + + if /p & /x then + if /openS := set() then + { + OpenCheck_open :=: open + OpenCheck_close :=: close + } + else + runerr(123, \p | \x ) +} +return +end + +procedure OpenCheck_open( x[] ) +return OpenCheck(OpenCheck_open,x) +end + +procedure OpenCheck_close( x[] ) +return OpenCheck(OpenCheck_close,x) +end diff --git a/ipl/procs/opnames.icn b/ipl/procs/opnames.icn new file mode 100644 index 0000000..42aaac3 --- /dev/null +++ b/ipl/procs/opnames.icn @@ -0,0 +1,130 @@ +############################################################################ +# +# File: opnames.icn +# +# Subject: Procedure to produce opcode/names table +# +# Author: Ralph E. Griswold +# +# Date: December 2, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# opnames() produces a table that maps virtual-machine instruction numbers +# to instruction names. +# +############################################################################ + +procedure opnames() + local opmap + + initial { + opmap := table("") + + opmap[1] := "Asgn" + opmap[2] := "Bang" + opmap[3] := "Cat" + opmap[4] := "Compl" + opmap[5] := "Diff" + opmap[6] := "Div" + opmap[7] := "Eqv" + opmap[8] := "Inter" + opmap[9] := "Lconcat" + opmap[10] := "Lexeq" + opmap[11] := "Lexge" + opmap[12] := "Lexgt" + opmap[13] := "Lexle" + opmap[14] := "Lexlt" + opmap[15] := "Lexne" + opmap[16] := "Minus" + opmap[17] := "Mod" + opmap[18] := "Mult" + opmap[19] := "Neg" + opmap[20] := "Neqv" + opmap[21] := "Nonnull" + opmap[22] := "Null" + opmap[23] := "Number" + opmap[24] := "Numeq" + opmap[25] := "Numge" + opmap[26] := "Numgt" + opmap[27] := "Numle" + opmap[28] := "Numlt" + opmap[29] := "Numne" + opmap[30] := "Plus" + opmap[31] := "Power" + opmap[32] := "Random" + opmap[33] := "Rasgn" + opmap[34] := "Refresh" + opmap[35] := "Rswap" + opmap[36] := "Sect" + opmap[37] := "Size" + opmap[38] := "Subsc" + opmap[39] := "Swap" + opmap[40] := "Tabmat" + opmap[41] := "Toby" + opmap[42] := "Unions" + opmap[43] := "Value" + opmap[44] := "Bscan" + opmap[45] := "Ccase" + opmap[46] := "Chfail" + opmap[47] := "Coact" + opmap[48] := "Cofail" + opmap[49] := "Coret" + opmap[50] := "Create" + opmap[51] := "Cset" + opmap[52] := "Dup" + opmap[53] := "Efail" + opmap[54] := "Eret" + opmap[55] := "Escan" + opmap[56] := "Esusp" + opmap[57] := "Field" + opmap[58] := "Goto" + opmap[59] := "Init" + opmap[60] := "Int" + opmap[61] := "Invoke" + opmap[62] := "Keywd" + opmap[63] := "Limit" + opmap[64] := "Line" + opmap[65] := "Llist" + opmap[66] := "Lsusp" + opmap[67] := "Mark" + opmap[68] := "Pfail" + opmap[69] := "Pnull" + opmap[70] := "Pop" + opmap[71] := "Pret" + opmap[72] := "Psusp" + opmap[73] := "Push1" + opmap[74] := "Pushn1" + opmap[75] := "Real" + opmap[76] := "Sdup" + opmap[77] := "Str" + opmap[78] := "Unmark" + opmap[80] := "Var" + opmap[81] := "Arg" + opmap[82] := "Static" + opmap[83] := "Local" + opmap[84] := "Global" + opmap[85] := "Mark0" + opmap[86] := "Quit" + opmap[87] := "FQuit" + opmap[88] := "Tally" + opmap[89] := "Apply" + opmap[90] := "Acset" + opmap[91] := "Areal" + opmap[92] := "Astr" + opmap[93] := "Aglobal" + opmap[94] := "Astatic" + opmap[95] := "Agoto" + opmap[96] := "Amark" + opmap[98] := "Noop" + opmap[100] := "SymEvents" + opmap[108] := "Colm" + } + + return opmap + +end diff --git a/ipl/procs/opsyms.icn b/ipl/procs/opsyms.icn new file mode 100644 index 0000000..ba49d8e --- /dev/null +++ b/ipl/procs/opsyms.icn @@ -0,0 +1,82 @@ +############################################################################ +# +# File: opsyms.icn +# +# Subject: Procedures to produce table to map opcodes to symbols +# +# Author: Ralph E. Griswold +# +# Date: July 10, 1992 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# opsyms() produces a table that maps virtual-machine instruction numbers +# for operators to operator symbols. The suffixes 1 and 2 are used +# for symbols that have both a unary and binary meaning. +# +############################################################################ + +procedure opsyms() + local opmap + + initial { + opmap := table() + + opmap[1] := ":=" + opmap[2] := "!1" + opmap[3] := "||" + opmap[4] := "~" + opmap[5] := "--" + opmap[6] := "/1" + opmap[7] := "===" + opmap[8] := "**" + opmap[9] := "|||" + opmap[10] := "==" + opmap[11] := ">==" + opmap[12] := ">>" + opmap[13] := "<==" + opmap[14] := "<<" + opmap[15] := "~==" + opmap[16] := "-2" + opmap[17] := "%" + opmap[18] := "*2" + opmap[19] := "-1" + opmap[20] := "~===" + opmap[21] := "\\1" + opmap[22] := "/1" + opmap[23] := "+1" + opmap[24] := "=2" + opmap[25] := ">=" + opmap[26] := ">" + opmap[27] := "<=" + opmap[28] := "<" + opmap[29] := "~=" + opmap[30] := "+2" + opmap[31] := "^2" + opmap[32] := "?1" + opmap[33] := "<-" + opmap[34] := "^1" + opmap[35] := "<->" + opmap[36] := "[:]" + opmap[37] := "*1" + opmap[38] := "[]" + opmap[39] := ":=:" + opmap[40] := "=1" + opmap[41] := "..." + opmap[42] := "++" + opmap[43] := ".1" + opmap[44] := "?2" + opmap[47] := "@" + opmap[57] := ".2" + opmap[62] := "&" + opmap[63] := "\\2" + opmap[65] := "[...]" + } + + return opmap + +end diff --git a/ipl/procs/options.icn b/ipl/procs/options.icn new file mode 100644 index 0000000..965d09d --- /dev/null +++ b/ipl/procs/options.icn @@ -0,0 +1,180 @@ +############################################################################ +# +# File: options.icn +# +# Subject: Procedure to get command-line options +# +# Authors: Robert J. Alexander and Gregg M. Townsend +# +# Date: May 5, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# options(arg, optstring,errproc) removes command options from the +# argument list of an Icon main procedure, returning a table of +# option values. +# +############################################################################ +# +# options(arg,optstring,errproc) -- Get command line options. +# +# This procedure separates and interprets command options included in +# the main program argument list. Option names and values are removed +# from the argument list and returned in a table. +# +# On the command line, options are introduced by a "-" character. An +# option name is either a single printable character, as in "-n" or "-?", +# or a string of letters, numbers, and underscores, as in "-geometry". +# Valueless single-character options may appear in combination, for +# example as "-qtv". +# +# Some options require values. Generally, the option name is one +# argument and the value appears as the next argument, for example +# "-F file.txt". However, with a single-character argument name +# (as in that example), the value may be concatenated: "-Ffile.txt" +# is accepted as equivalent. +# +# Options may be freely interspersed with non-option arguments. +# An argument of "-" is treated as a non-option. The special argument +# "--" terminates option processing. Non-option arguments are returned +# in the original argument list for interpretation by the caller. +# +# An argument of the form @filename (a "@" immediately followed +# by a file name) causes options() to replace that argument with +# arguments retrieved from the file "filename". Each line of the file +# is taken as a separate argument, exactly as it appears in the file. +# Arguments beginning with - are processed as options, and those +# starting with @ are processed as nested argument files. An argument +# of "--" causes all remaining arguments IN THAT FILE ONLY to be +# treated as non-options (including @filename arguments). +# +# The parameters of options(arg,optstring,errproc) are: +# +# arg the argument list as passed to the main procedure. +# +# optstring a string specifying the allowable options. This is +# a concatenation, with optional spaces between, of +# one or more option specs of the form +# -name% +# where +# - introduces the option +# name is either a string of alphanumerics +# (any of a-z, A-Z, 0-9, and _) +# or any single printable character +# % is one of the following flag characters: +# ! No value is required or allowed +# : A string value is required +# + An integer value is required +# . A real value is required +# +# The leading "-" may be omitted for a single-character +# option. The "!" flag may be omitted except when +# needed to terminate a multi-character name. +# Thus, the following optstrings are equivalent: +# "-n+ -t -v -q -F: -geometry: -silent" +# "n+tvqF:-geometry:-silent" +# "-silent!n+tvqF:-geometry:" +# +# If "optstring" is omitted any single letter is +# assumed to be valid and require no data. +# +# errproc a procedure which will be called if an error is +# is detected in the command line options. The +# procedure is called with one argument: a string +# describing the error that occurred. After errproc() +# is called, options() immediately returns the outcome +# of errproc(), without processing further arguments. +# Already processed arguments will have been removed +# from "arg". If "errproc" is omitted, stop() is +# called if an error is detected. +# +# A table is returned containing the options that were specified. +# The keys are the specified option names. The assigned values are the +# data values following the options converted to the specified type. +# A value of 1 is stored for options that accept no values. +# The table's default value is &null. +# +# Upon return, the option arguments are removed from arg, leaving +# only the non-option arguments. +# +############################################################################ + +procedure options(arg,optstring,errproc) + local f,fList,fileArg,fn,ignore,optname,opttable,opttype,p,x,option,optcs + # + # Initialize. + # + /optstring := string(&letters) + /errproc := stop + option := table() + fList := [] + opttable := table() + optcs := &lcase ++ &ucase ++ &digits ++ '_' + # + # Scan the option specification string. + # + optstring ? { + while optname := move(1) do { + if optname == " " then next + if optname == "-" then + optname := tab(many(optcs)) | move(1) | break + opttype := tab(any('!:+.')) | "!" + opttable[optname] := opttype + } + } + # + # Iterate over program invocation argument words. + # + while x := get(arg) do { + if /x then ignore := &null # if end of args from file, stop ignoring + else x ? { + if ="-" & not pos(0) & /ignore then { + if ="-" & pos(0) then ignore := 1 # ignore following args if -- + else { + tab(0) ? until pos(0) do { + if opttype := \opttable[ + optname := ((pos(1),tab(0)) | move(1))] then { + option[optname] := + if any(':+.',opttype) then { + p := "" ~== tab(0) | get(arg) | + return errproc( + "No parameter following -" || optname) + case opttype of { + ":": p + "+": integer(p) | + return errproc("-" || optname || + " needs numeric parameter") + ".": real(p) | + return errproc("-" || optname || + " needs numeric parameter") + } + } + else 1 + } + else return errproc("Unrecognized option: -" || optname) + } + } + } + # + # If the argument begins with the character "@", fetch option + # words from lines of a text file. + # + else if ="@" & not pos(0) & /ignore then { + f := open(fn := tab(0)) | + return errproc("Can't open " || fn) + fileArg := [] + while put(fileArg,read(f)) + close(f) + push(arg) # push null to signal end of args from file + while push(arg,pull(fileArg)) + } + else put(fList,x) + } + } + while push(arg,pull(fList)) + return option +end diff --git a/ipl/procs/outbits.icn b/ipl/procs/outbits.icn new file mode 100644 index 0000000..d9effd8 --- /dev/null +++ b/ipl/procs/outbits.icn @@ -0,0 +1,106 @@ +############################################################################ +# +# File: outbits.icn +# +# Subject: Procedure to write variable-length characters +# +# Author: Richard L. Goerwitz +# +# Date: November 3, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.5 +# +############################################################################ +# +# In any number of instances (e.g. when outputting variable-length +# characters or fixed-length encoded strings), the programmer must +# fit variable and/or non-byte-sized blocks into standard 8-bit +# bytes. Outbits() performs this task. +# +# Pass to outbits(i, len) an integer i, and a length parameter (len), +# and outbits will suspend byte-sized chunks of i converted to +# characters (most significant bits first) until there is not enough +# left of i to fill up an 8-bit character. The remaining portion is +# stored in a buffer until outbits() is called again, at which point +# the buffer is combined with the new i and then output in the same +# manner as before. The buffer is flushed by calling outbits() with +# a null i argument. Note that len gives the number of bits there +# are in i (or at least the number of bits you want preserved; those +# that are discarded are the most significant ones). +# +# A trivial example of how outbits() might be used: +# +# outtext := open("some.file.name","w") +# l := [1,2,3,4] +# every writes(outtext, outbits(!l,3)) +# writes(outtext, outbits(&null,3)) # flush buffer +# +# List l may be reconstructed with inbits() (see inbits.icn): +# +# intext := open("some.file.name") +# l := [] +# while put(l, inbits(intext, 3)) +# +# Note that outbits() is a generator, while inbits() is not. +# +############################################################################ +# +# See also: inbits.icn +# +############################################################################ + +procedure outbits(i, len) + + local old_part, new_part, window, old_byte_mask + static old_i, old_len, byte_length, byte_mask + initial { + old_i := old_len := 0 + byte_length := 8 + byte_mask := (2^byte_length)-1 + } + + old_byte_mask := (0 < 2^old_len - 1) | 0 + window := byte_length - old_len + old_part := ishift(iand(old_i, old_byte_mask), window) + + # If we have a no-arg invocation, then flush buffer (old_i). + if /i then { + if old_len > 0 then { + old_i := old_len := 0 + return char(old_part) + } else { + old_i := old_len := 0 + fail + } + } else { + new_part := ishift(i, window-len) + len -:= (len >= window) | { + old_len +:= len + old_i := ior(ishift(old_part, len-window), i) + fail + } +# For debugging purposes. +# write("old_byte_mask = ", old_byte_mask) +# write("window = ", image(window)) +# write("old_part = ", image(old_part)) +# write("new_part = ", image(new_part)) +# write("outputting ", image(ior(old_part, new_part))) + suspend char(ior(old_part, new_part)) + } + + until len < byte_length do { + suspend char(iand(ishift(i, byte_length-len), byte_mask)) + len -:= byte_length + } + + old_len := len + old_i := i + fail + +end diff --git a/ipl/procs/packunpk.icn b/ipl/procs/packunpk.icn new file mode 100644 index 0000000..3babbf3 --- /dev/null +++ b/ipl/procs/packunpk.icn @@ -0,0 +1,134 @@ +############################################################################ +# +# File: packunpk.icn +# +# Subject: Procedures to pack and unpack decimal strings +# +# Author: C. Tenaglia (modified by Richard L. Goerwitz) +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.2 +# +############################################################################ +# +# Integers written directly as strings occupy much more space +# than they need to. One easy way to shrink them a bit is to "pack" +# them, i.e. convert each decimal digit into a four-byte binary +# code, and pack these four-bit chunks into eight-bit characters, +# which can be written to a file. +# +# Interestingly, packing decimal strings in this manner lends +# itself to unpacking by treating each character as a base-10 +# integer, and then converting it to base-16. Say we have an input +# string "99." Pack() would convert it to an internal representation +# of char(16*9 + 9), i.e. char(153). Unpack would treat this +# char(153) representation as a base-10 integer, and convert it to +# base 16 (i.e. 10r153 -> 16r99). The 99 is, of course, what we +# started with. +# +# Note that two unpack routines are provided here: The first, by +# Tanaglia, utilizes convert.icn from the IPL. The second, by +# Goerwitz, does not. They utilize very different methods, but both +# amount to basically the same thing. Goerwitz's routine returns an +# integer, though, and has no "width" argument. +# +############################################################################ +# +# Links: convert +# +############################################################################ + +link convert + +procedure pack(num,width) + + local int, sign, prep, packed, word + + int := integer(num) | fail + # There's really no need to store the sign if it's positive, UNLESS + # you are using this program to store packed decimal integers for + # access by other programs on certain mainframes that always store + # the sign. + # if int < 0 then sign := "=" else sign := "<" + if int < 0 then sign := "=" else sign := "" + prep := string(abs(int)) || sign + packed := "" + if (*prep % 2) ~= 0 then prep := "0" || prep + + prep ? { + while word := move(2) do { + if pos(0) + then packed ||:= char(integer(word[1])*16 + ord(word[2])-48) + else packed ||:= char(integer(word[1])*16 + integer(word[2])) + } + } + + /width := *packed + return right(packed, width, "\0") + +end + + + +procedure unpack(val,width) + + # THIS PROCEDURE UNPACKS A VALUE INTO A STRING-INTEGER. USING THIS + # CODE SEGMENT REQUIRES LINKING WITH RADCON FROM THE IPL. + + local tmp, number, tens, ones, sign + + tmp := "" + sign := 1 + + every number := ord(!val) do + tmp ||:= right(map(radcon(number,10,16),&lcase,&ucase),2,"0") + + if tmp[-1] == ("B" | "D") then { + sign := -1 + # In this configuration, the sign field is only present if the + # integer is negative. If you have set up pack to register posi- + # tive values in the sign field, place the following line after + # the "if-then" expression. + tmp[-1] := "" + } + tmp *:= sign + /width := *string(tmp) + + return right(string(tmp), width) + +end + + + +procedure unpack2(val) + + # THIS PROCEDURE UNPACKS A VALUE INTO AN STRING-INTEGER. + # Note: Unpack2 assumes that pack is not recording positive + # sign values. + + local unpacked, int + + unpacked := "" + val ? { + while int := ord(move(1)) do { + unpacked ||:= string(iand(2r11110000,int) / 16) + if pos(0) then { + if iand(2r00001111,int) = 13 then { + unpacked := "-" || unpacked + break + } + } + unpacked ||:= string(iand(2r00001111,int)) + } + } + + return integer(unpacked) + +end diff --git a/ipl/procs/parscond.icn b/ipl/procs/parscond.icn new file mode 100644 index 0000000..2a7ce88 --- /dev/null +++ b/ipl/procs/parscond.icn @@ -0,0 +1,39 @@ +############################################################################ +# +# File: parscond.icn +# +# Subject: Procedure to condense parse tree +# +# Author: Ralph E. Griswold +# +# Date: March 31, 1992 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Procedure to condense a parse tree produced by the output of pargen.icn +# and produce the string that was parsed. +# +# The necessary record declaration is provided by the program with which +# is linked. +# +############################################################################ +# +# See also: parsgen.icn +# +############################################################################ + +procedure parscond(R) + local result, x + + result := "" + + every x := !(R.alts) do + result ||:= string(x) | parscond(x) + + return result + +end diff --git a/ipl/procs/partit.icn b/ipl/procs/partit.icn new file mode 100644 index 0000000..1432d8e --- /dev/null +++ b/ipl/procs/partit.icn @@ -0,0 +1,107 @@ +########################################################################### +# +# File: partit.icn +# +# Subject: Procedures to partition integer +# +# Author: Ralph E. Griswold +# +# Date: December 5, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# partit(i, min, max) generates, as lists, the partitions of i; that is the +# ways that i can be represented as a sum of positive integers with +# minimum and maximum values. +# +# partcount(i, min, max) returns just the number of partitions. +# +# fibpart(i) returns a list of Fibonacci numbers that is a partition of i. +# +############################################################################ +# +# Links: fastfncs, numbers +# +############################################################################ + +link fastfncs +link numbers + +procedure partit(i, min, max, k) + local j + + if not(integer(i)) | (i < 0) | (\min > \max) then + stop("*** illegal argument to partit(i)") + + /min := 1 + /max := i + max >:= i + /k := i + k >:= max + k >:= i + + if i = 0 then return [] + + every j := k to min by -1 do { + suspend push(partit(i - j, min, max, j), j) + } + +end + +procedure partcount(i, min, max) + local count + + count := 0 + + every partitret(i, min, max) do + count +:= 1 + + return count + +end + +# This is a version of partit() that doesn't do all the work +# of producing the partitions and is used only by partcount(). + +procedure partitret(i, min, max, k) + local j + + /min := 1 + /max := i + max >:= i + /k := i + k >:= max + k >:= i + + if i = 0 then return + + every j := k to min by -1 do { + suspend partitret(i - j, min, max, j) + } + +end + +# Partition of an integer into Fibonacci numbers. + +procedure fibpart(i) + local partl, n + static m + + initial m := 1 / log(( 1 + sqrt(5)) / 2) + + partl := [] + + while i > 2 do { + push(partl, n := fib(ceil(log(i) * m))) + i -:= n + } + + if i > 0 then push(partl, i) + + return partl + +end diff --git a/ipl/procs/pascal.icn b/ipl/procs/pascal.icn new file mode 100644 index 0000000..92da5ef --- /dev/null +++ b/ipl/procs/pascal.icn @@ -0,0 +1,48 @@ +############################################################################ +# +# File: pascal.icn +# +# Subject: Procedure to write Pascal triangles +# +# Author: Ralph E. Griswold +# +# Date: August 3, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure writes numeric triangles as "carpets". +# +# The argument determines the number of rows written, default 16. +# +############################################################################ +# +# Requires: large integers +# +############################################################################ +# +# Links: math +# +############################################################################ + +link math + +# The Pascal Triangle + +procedure pascal(n) #: Pascal triangle + local i, j + + /n := 16 + + write("width=", n, " height=", n) # carpet header + + every i := 0 to n - 1 do { + every j := 0 to n - 1 do + writes(binocoef(i, j) | 0, " ") + write() + } + +end diff --git a/ipl/procs/pascltri.icn b/ipl/procs/pascltri.icn new file mode 100644 index 0000000..6ce8442 --- /dev/null +++ b/ipl/procs/pascltri.icn @@ -0,0 +1,54 @@ +############################################################################ +# +# File: pascltri.icn +# +# Subject: Procedure to compute a row of Pascal's Triangle +# +# Author: Erik Eid +# +# Date: August 7, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# The procedure, when invoked by a call to PascalsTriangle(n), returns +# the nth row of Pascal's Triangle in list form. Pascal's Triangle is a +# mathematical structure in which each element of a row is the sum of the +# two elements directly above it. The first few levels are: +# +# Row 1: 1 Triangle stored as: [[1], +# 2: 1 1 [1, 1], +# 3: 1 2 1 [1, 2, 1], +# 4: 1 3 3 1 [1, 3, 3, 1], +# 5: 1 4 6 4 1 [1, 4, 6, 4, 1]] +# +# For example, PascalsTriangle(4) would return the list [1, 3, 3, 1]. +# +# The procedure fails if n is not an integer or if it is less than one. +# +############################################################################ + +procedure PascalsTriangle(level) #: Pascal triangle row +static tri +local row, elem, temp +initial tri := [[1], [1, 1]] # Start with first two rows stored + if not (level = integer(level)) then fail + if level < 1 then fail + if level > *tri then # If we haven't calculated this + # row before, then do so and keep + # it statically to prevent having + # to do so again. + every row := *tri+1 to level do { + temp := [1] # First element of any row is 1. + every elem := 2 to row-1 do # Each of the next elements is + put (temp, tri[row-1][elem-1] + # the sum of the two above it. + tri[row-1][elem]) + put (temp, 1) # Last element of any row is 1. + put (tri, temp) # Attach this row to the triangle. + } + return tri[level] # Return the chosen level. +end + diff --git a/ipl/procs/patch.icn b/ipl/procs/patch.icn new file mode 100644 index 0000000..88e023c --- /dev/null +++ b/ipl/procs/patch.icn @@ -0,0 +1,92 @@ +############################################################################ +# +# File: patch.icn +# +# Subject: Procedures for UNIX-like patch(1) +# +# Author: Rich Morin +# +# Date: June 18, 1990 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure produces a sequence of edited items, reading a source +# stream (from) and a stream of difference records (diffs), as generated +# by dif.icn. +# +# An optional parameter (rev) causes the edits to be made in reverse. +# This allows an old stream to be regenerated from a new stream and an +# appropriate stream of difference records. +# +# The original patch(1) utility was written by Larry Wall, and is used +# widely in the UNIX community. See also diffu.icn and patchu.icn, the +# utility program versions of dif.icn and patch.icn. +# +# Usage: patch(old, diff) # patch old to new via diff +# patch(new, diff, rev) # patch new to old via diff +# +############################################################################ +# +# Requires: co-expressions +# +############################################################################ + +procedure patch(from, diff, rev) + local c_diff, c_from, cnte, cnti, i, item, ldr, o + + initial { + i := 1 + o := 2 + if \rev then + i :=: o + + c_diff := create !diff + c_from := create !from + + cnti := item := 0 + ldr := @c_diff + cnte := ldr[i].pos + } + + repeat { + + while /ldr | cnti < cnte-1 do { # copy old items + cnti +:= 1 + if item := @c_from then + suspend item + else { + item := &null + break + } + } + + if \ldr then { # still have edits + every 1 to *ldr[i].diffs do { # discard items + cnti +:= 1 + @c_from | zot_patch("unexpected end of stream") + } + + if *ldr[o].diffs > 0 then # copy new items + suspend !ldr[o].diffs + + if ldr := @c_diff then # get next edit + cnte := ldr[i].pos + else + ldr := &null + } + + if /item & /ldr then + fail + } + +end + + +procedure zot_patch(msg) # exit w/ message + write(&errout, "patch: ", msg) + exit(1) +end diff --git a/ipl/procs/patterns.icn b/ipl/procs/patterns.icn new file mode 100644 index 0000000..6099a46 --- /dev/null +++ b/ipl/procs/patterns.icn @@ -0,0 +1,248 @@ +############################################################################ +# +# File: patterns.icn +# +# Subject: Procedures for SNOBOL4-style pattern matching +# +# Author: Ralph E. Griswold +# +# Date: June 10, 1988 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures provide procedural equivalents for most SNOBOL4 +# patterns and some extensions. +# +# Procedures and their pattern equivalents are: +# +# Any(s) ANY(S) +# +# Arb() ARB +# +# Arbno(p) ARBNO(P) +# +# Arbx(i) ARB(I) +# +# Bal() BAL +# +# Break(s) BREAK(S) +# +# Breakx(s) BREAKX(S) +# +# Cat(p1,p2) P1 P2 +# +# Discard(p) /P +# +# Exog(s) \S +# +# Find(s) FIND(S) +# +# Len(i) LEN(I) +# +# Limit(p,i) P \ i +# +# Locate(p) LOCATE(P) +# +# Marb() longest-first ARB +# +# Notany(s) NOTANY(S) +# +# Pos(i) POS(I) +# +# Replace(p,s) P = S +# +# Rpos(i) RPOS(I) +# +# Rtab(i) RTAB(I) +# +# Span(s) SPAN(S) +# +# String(s) S +# +# Succeed() SUCCEED +# +# Tab(i) TAB(I) +# +# Xform(f,p) F(P) +# +# The following procedures relate to the application and control +# of pattern matching: +# +# Apply(s,p) S ? P +# +# Mode() anchored or unanchored matching (see Anchor +# and Float) +# +# Anchor() &ANCHOR = 1 if Mode := Anchor +# +# Float() &ANCHOR = 0 if Mode := Float +# +# In addition to the procedures above, the following expressions +# can be used: +# +# p1() | p2() P1 | P2 +# +# v <- p() P . V (approximate) +# +# v := p() P $ V (approximate) +# +# fail FAIL +# +# =s S (in place of String(s)) +# +# p1() || p2() P1 P2 (in place of Cat(p1,p2)) +# +# Using this system, most SNOBOL4 patterns can be satisfactorily +# transliterated into Icon procedures and expressions. For example, +# the pattern +# +# SPAN("0123456789") $ N "H" LEN(*N) $ LIT +# +# can be transliterated into +# +# (n <- Span('0123456789')) || ="H" || +# (lit <- Len(n)) +# +# Concatenation of components is necessary to preserve the +# pattern-matching properties of SNOBOL4. +# +# Caveats: Simulating SNOBOL4 pattern matching using the procedures +# above is inefficient. +# +############################################################################ + +global Mode, Float + +procedure Anchor() # &ANCHOR = 1 + suspend "" +end + +procedure Any(s) # ANY(S) + suspend tab(any(s)) +end + +procedure Apply(s,p) # S ? P + local tsubject, tpos, value + initial { + Float := Arb + /Mode := Float # &ANCHOR = 0 if not already set + } + suspend ( + (tsubject := &subject) & + (tpos := &pos) & + (&subject <- s) & + (&pos <- 1) & + (Mode() & (value := p())) & + (&pos <- tpos) & # to restore on backtracking + (&subject <- tsubject) & # note this sets &pos + (&pos <- tpos) & # to restore on evaluation + value + ) +end + +procedure Arb() # ARB + suspend tab(&pos to *&subject + 1) +end + +procedure Arbno(p) # ARBNO(P) + suspend "" | (p() || Arbno(p)) +end + +procedure Arbx(i) # ARB(I) + suspend tab(&pos to *&subject + 1 by i) +end + +procedure Bal() # BAL + suspend Bbal() || Arbno(Bbal) +end + +procedure Bbal() # used by Bal() + suspend (="(" || Arbno(Bbal) || =")") | Notany("()") +end + +procedure Break(s) # BREAK(S) + suspend tab(upto(s) \ 1) +end + +procedure Breakx(s) # BREAKX(S) + suspend tab(upto(s)) +end + +procedure Cat(p1,p2) # P1 P2 + suspend p1() || p2() +end + +procedure Discard(p) # /P + suspend p() & "" +end + +procedure Exog(s) # \S + suspend s +end + +procedure Find(s) # FIND(S) + suspend tab(find(s) + 1) +end + +procedure Len(i) # LEN(I) + suspend move(i) +end + +procedure Limit(p,i) # P \ i + local j + j := &pos + suspend p() \ i + &pos := j +end + +procedure Locate(p) # LOCATE(P) + suspend tab(&pos to *&subject + 1) & p() +end + +procedure Marb() # max-first ARB + suspend tab(*&subject + 1 to &pos by -1) +end + +procedure Notany(s) # NOTANY(S) + suspend tab(any(~s)) +end + +procedure Pos(i) # POS(I) + suspend pos(i + 1) & "" +end + +procedure Replace(p,s) # P = S + suspend p() & s +end + +procedure Rpos(i) # RPOS(I) + suspend pos(-i) & "" +end + +procedure Rtab(i) # RTAB(I) + suspend tab(-i) +end + +procedure Span(s) # SPAN(S) + suspend tab(many(s)) +end + +procedure String(s) # S + suspend =s +end + +procedure Succeed() # SUCCEED + suspend |"" +end + +procedure Tab(i) # TAB(I) + suspend tab(i + 1) +end + +procedure Xform(f,p) # F(P) + suspend f(p()) +end diff --git a/ipl/procs/patword.icn b/ipl/procs/patword.icn new file mode 100644 index 0000000..e8fd1d3 --- /dev/null +++ b/ipl/procs/patword.icn @@ -0,0 +1,46 @@ +############################################################################ +# +# File: patword.icn +# +# Subject: Procedures to find letter patterns +# +# Author: Kenneth Walker +# +# Date: December 2, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# The procedure patword(s) returns a letter pattern in which each +# different character in s is assigned a letter. For example, +# patword("structural") returns "abcdebdcfg". +# +############################################################################ + +procedure patword(s) + local numbering, orderS, orderset, patlbls + static labels, revnum + + initial { + labels := &lcase || &lcase + revnum := reverse(&cset) + } + +# First map each character of s into another character, such that the +# the new characters are in increasing order left to right (note that +# the map function chooses the rightmost character of its second +# argument, so things must be reversed. +# +# Next map each of these new characters into contiguous letters. + + numbering := revnum[1 : *s + 1] | stop("word too long") + orderS := map(s, reverse(s), numbering) + orderset := string(cset(orderS)) + patlbls := labels[1 : *orderset + 1] | stop("too many characters") + + return map(orderS, orderset, patlbls) + +end diff --git a/ipl/procs/pbkform.icn b/ipl/procs/pbkform.icn new file mode 100644 index 0000000..698a9aa --- /dev/null +++ b/ipl/procs/pbkform.icn @@ -0,0 +1,136 @@ +############################################################################ +# +# File: pbkform.icn +# +# Subject: Procedures to process HP95 phone book files +# +# Author: Robert J. Alexander +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Icon procedure set to read and write HP95LX phone book (.pbk) files. +# +############################################################################ +# +# HP 95LX Phone Book File Format +# +# The HP 95LX Phone Book file is structured as a file identification +# record, followed by a variable number of phone book data records, +# and terminated by an end of file record. Each data record contains +# the information for one phone book entry. +# +# The format of these phone book records is described below. In the +# descriptions, the type <int> refers to a two byte integer stored least +# significant byte first, the type <char> refers to a one byte integer, +# and the type <ASCII> refers to a string of ASCII characters. +# +# HP 95LX Phone Book File Identification Record: +# +# Byte Offset Name Type Contents +# +# 0 ProductCode int -2 (FEh, FFh) +# 2 ReleaseNum int 1 (01h, 00h) +# 4 FileType char 3 (03h) +# +############################################################################ +# +# Links: bkutil +# +############################################################################ +# +# See also: pbkutil.icn, abkform.icn +# +############################################################################ + +link bkutil + +record pbk_id(releaseNum,fileType) + +procedure pbk_write_id(f) + writes(f,"\xfe\xff\x01\x00\x03") + return +end + +procedure pbk_read_id(f) + bk_read_int(f) = 16rfffe | fail + return pbk_id(bk_read_int(f),ord(reads(f))) +end + +# +# HP 95LX Phone Book Data Record: +# +# Byte Offset Name Type Contents +# +# 0 RecordType char 1 (01h) +# 1 RecordLength int Number of bytes in remainder +# of this data record, see note +# below. +# 3 NameLength char Length of name text in bytes. +# 4 NumberLength char Length on number text in bytes. +# 5 AddressLength int Length of address text in bytes. +# 7 NameText ASCII Name text, 30 characters maximum. +# 7+NameLength NumberText ASCII Number text, 30 characters maximum. +# 7+NameLength+ +# NumberLength AddressText ASCII Address text where the null +# character is used as the line +# terminator. Addresses are limited +# to a maximum of 8 lines of 39 +# characters per line (not counting +# the line terminator). +# +record pbk_data(name,number,address) + +procedure pbk_write_data(f,data) + local name,number,address + name := \data.name | "" + number := \data.number | "" + address := \data.address | "" + writes(f,"\x01",bk_int(*name + *number + *address + 4),char(*name), + char(*number),bk_int(*address),name,number,address) + return data +end + +procedure pbk_read_data(f,id) + local next_rec,name_len,number_len,address_len,data + (reads(f) == "\x01" | (seek(f,where(f) - 1),&fail) & + next_rec := bk_read_int(f) + where(f) & + name_len := ord(reads(f)) & + number_len := ord(reads(f)) & + address_len := bk_read_int(f) & + data := pbk_data(reads(f,0 ~= name_len) | "",reads(f,0 ~= number_len) | "", + reads(f,0 ~= address_len) | "") | fail & + seek(f,next_rec)) | fail + return data +end + +# +# HP 95LX Phone Book End of File Record: +# +# Byte Offset Name Type Contents +# +# 0 RecordType char 2 (02h) +# 1 RecordLength int 0 (00h, 00h) +# +procedure pbk_write_end(f) + writes(f,"\x02\x00\x00") + return +end + +procedure pbk_read_end(f,id) + (reads(f) == "\x02" & reads(f,2)) | fail + return +end + +# +# +# Note: Files created by the Phone Book application may contain +# some padding following the last field of some data records. Hence, +# the RecordLength field must be used to determine the start of the +# next record. Phone book files created by other programs need not +# have any padding. diff --git a/ipl/procs/pdco.icn b/ipl/procs/pdco.icn new file mode 100644 index 0000000..cd239c1 --- /dev/null +++ b/ipl/procs/pdco.icn @@ -0,0 +1,1197 @@ +############################################################################ +# +# File: pdco.icn +# +# Subject: Procedures for programmer-defined control operations +# +# Authors: Ralph E. Griswold and Robert J. Alexander +# +# Date: March 4, 2003 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures use co-expressions to used to model the built-in +# control structures of Icon and also provide new ones. +# +# AddTabbyPDCO{e, i} adds tabby to treadling sequence +# +# AllparAER{e1,e2, ...} +# parallel evaluation with last result +# used for short sequences +# +# AltPDCO{e1,e2} models e1 | e2 +# +# BinopPDCO{op,e1,e2} produces the result of applying op to e1 and e2 +# +# CFapproxPDCO{e} produce sequence of approximations for the +# continued-fraction sequence e +# +# ComparePDCO{e1,e2} compares result sequences of e1 and e2 +# +# ComplintPDCO{e} produces the integers not in e +# +# CondPDCO{e1,e2, ...} +# models the generalized Lisp conditional +# +# CumsumPDCO{e} generates the cumulative sum of the terms of e +# +# CycleparAER{e1,e2, ...} +# parallel evaluation with shorter sequences +# re-evaluated +# +# DecimatePDCO{e1, e2} +# "decimate" e1 by deleting e2-numbered terms +# (e2 is assumed to be an increasing sequence). +# +# DecimationPDCO{e} produce a decimation sequence from e1 by +# deleting even-valued terms and replacing +# odd-valued terms by their position. +# +# DecollatePDCO{e, i} decollate e according to parity of i +# +# DeltaPDCO{e1} produces the difference of the values in e1 +# +# ElevatePDCO{e1, m, n} +# elevate e1 mod n to n values +# +# EveryPDCO{e1,e2} models every e1 do e2 +# +# ExtendSeqPDCO{e1,i} extends e1 to i results +# +# ExtractAER{e1,e2, ...} +# extract results of even-numbered arguments +# according to odd-numbered values +# +# FifoAER{e1,e2, ...} reversal of lifo evaluation +# +# FriendlyPDCO{m, k, e3} +# friendly sequence starting at k shaft mod m +# +# GaltPDCO{e1,e2, ...} +# produces the results of concatenating the +# sequences for e1, e2, ... +# +# GconjPDCO{e1,e2,...} +# models generalized conjunction: e1 & e2 & ... +# +# The programmer-defined control operation above shows an interesting +# technique for modeling conjunction via recursive generative +# procedures. +# +# HistoPDCO{e,i} generates histogram for e limited to i terms; +# default 100. +# +# IncreasingPDCO{e} filters out non-increasing values in integer +# sequence +# +# IndexPDCO{e1,e2} produce e2-th terms from e1 +# +# InterPDCO{e1,e2, ...} +# produces results of e1, e2, ... alternately +# +# LcondPDCO{e1,e2, ...} +# models the Lisp conditional +# +# LengthPDCO{e} returns the length of e +# +# LifoAER{e1,e2, ...} models standard Icon "lifo" evaluation +# +# LimitPDCO{e1,e2} models e1 \ e2 +# +# ListPDCO{e,i} produces a list of the first i results from e +# +# LowerTrimPDCO{e} lower trim +# +# MapPDCO{e1,e2} maps values of e1 in the order they first appear +# to values of e2 (as needed) +# +# OddEven{e} forces odd/even sequence +# +# PalinPDCO{e} x produces results of concatenating the +# sequences for e and then its reverse. +# +# ParallelPDCO{e1,e2, ...} +# synonym for InterPDCO{e1, e2, ...} +# +# ParallelAER{e1,e2, ...} +# parallel evaluation terminating on +# shortest sequence +# +# PatternPalinPDCO{e, i} +# produces pattern palindrome. If i is given, +# e is truncated to length i. +# +# PeriodPDCO{e, i} generates the periodic part of e; i values are +# used to find the period +# +# PermutePDCO{e1,e2} permutes each n-subsequence of e1 by the +# n positional values in lists from e2. If a list does +# not consist of all the integers in the range 1 to +# n, "interesting" things happen (see the use +# of map() for transpositions). +# +# PivotPDCO{e, m} produces pivot points from e % m; m default 100 +# +# PosDiffPDCO{e1,e2} produces positions at which e1 and e2 differ +# +# PositionsPDCO{e, i} generates the positions at which i occurs in e. +# +# RandomPDCO{e1,e2, ...} +# produces results of e1, e2, ... at random +# +# ReducePDCO{op, x, e} +# "reduces" the sequence e by starting with the value x +# and repetitively applying op to the current +# value and values from e. +# +# RemoveDuplPDCO{e} removes duplicate adjacent values. +# +# RepaltPDCO{e} models |e +# +# RepeatPDCO{e1, e2} repeats the sequence for e1 e2 times +# +# ReplPDCO{e1,e2} replicates each value in e1 by the corresponding +# integer value in e2. +# +# ResumePDCO{e1,e2,e3} +# models every e1 \ e2 do e3 +# +# ReversePDCO{e, i} produces the results of e in reverse order. If i +# is given, e is truncated to i values. +# +# RotatePDCO(e, i) rotates the sequence for e left by i; negative +# i rotates to the right +# +# SelfreplPDCO{e1,i} produces e1 * i copies of e1 +# +# SeqlistPDCO{e1, i} produce list with first i values of e1; i +# defaults to all values +# +# SimpleAER{e1,e2, ...} +# simple evaluation with only success or +# failure +# +# SkipPDCO{e1,e2} generate e1 skipping each e2 terms +# +# SmodPDCO{e1,e2} reduce terms in e1 (shaft) modulus e2 +# +# SpanPDCO{e,m} fill in between consecutive (integer) values in +# e % m; m default 100 +# +# SumlimitPDCO{e, i, j} +# produces values of e until their sum exceeds +# i. Values less than j are discarded. +# +# TrinopPDCO{op,e2,e2,e3} +# produces the result of applying op to e1, e2, and e3 +# +# UndulantPDCO{e} produces the undulant for e. +# +# UniquePDCO{e} produces the unique results of e in the order +# they first appear +# +# UnopPDCO{e1,e2} produces the result of applying e1 to e2 +# +# UpperTrimPDCO{e} upper trim +# +# ValrptPDCO{e1,e2} synonym for ReplPDCO +# +# WobblePDCO{e} produces e(1), e(2), e(1), e(2), e(3), e(2), ... +# +# Comments: +# +# Because of the handling of the scope of local identifiers in +# co-expressions, expressions in programmer-defined control +# operations cannot communicate through local identifiers. Some +# constructions, such as break and return, cannot be used in argu- +# ments to programmer-defined control operations. +# +############################################################################ +# +# Requires: co-expressions +# +############################################################################ +# +# Links: lists, periodic, rational +# +############################################################################ + +link lists +link periodic +link rational + +procedure AddTabbyPDCO(L) #: PDCO to add tabby to treadling + local i + + i := @L[2] | 4 # number of regular treadles + + suspend InterPDCO([L[1], create |((i + 1) | (i + 2))]) + +end + +procedure AllparAER(L) #: PDAE for parallel evaluation with repeats + local i, L1, done + + L1 := list(*L) + + done := list(*L,1) + + every i := 1 to *L do L1[i] := @L[i] | fail + + repeat { + suspend L1[1] ! L1[2:0] + every i := 1 to *L do + if done[i] = 1 then ((L1[i] := @L[i]) | (done[i] := 0)) + if not(!done = 1) then fail + } + +end + +procedure AltPDCO(L) #: PDCO to model alternation + + suspend |@L[1] + suspend |@L[2] + +end + +procedure BinopPDCO(L) #: PDCO to apply binary operation to sequences + local op, x, y + + repeat { + op := @L[1] + op := proc(op, 2) | fail + (x := @L[2] & y := @L[3]) | fail + suspend op(x, y) + } + +end + +procedure CFapproxPDCO(L) #: PDCO for continued-fraction approximations + local prev_n, prev_m, n, m, t + + prev_n := [1] + prev_m := [0, 1] + + put(prev_n, (@L[1]).denom) | fail + + while t := @L[1] do { + n := t.denom * get(prev_n) + t.numer * prev_n[1] + m := t.denom * get(prev_m) + t.numer * prev_m[1] + suspend rational(n, m, 1) + put(prev_n, n) + put(prev_m, m) + if t.denom ~= 0 then { # renormalize + every !prev_n /:= t.denom + every !prev_m /:= t.denom + } + } + +end + +procedure ComparePDCO(L) #: PDCO to compare sequences + local x1, x2 + + while x1 := @L[1] do + (x1 === @L[2]) | fail + if @L[2] then fail else return + +end + +procedure ComplintPDCO(L) #: PDCO to generate integers not in sequence + local i, j # EXPECTS MONOTONE NON-DECREASING SEQUENCE + + j := 0 + + while i := @L[1] do { + i := integer(i) | stop("*** invalid value in sequence to Compl{}") + suspend j to i - 1 + j := i + 1 + } + + suspend seq(j) + +end + +procedure CondPDCO(L) #: PDCO for generalized Lisp conditional + local i, x + + every i := 1 to *L do + if x := @L[i] then { + suspend x + suspend |@L[i] + fail + } + +end + +procedure CumsumPDCO(L) #: PDCO to produce cumulative sum + local i + + i := 0 + + while i +:= @L[1] do + suspend i + +end + +procedure CycleparAER(L) #: PDAE for parallel evaluation with cycling + local i, L1, done + + L1 := list(*L) + + done := list(*L,1) + + every i := 1 to *L do L1[i] := @L[i] | fail + + repeat { + suspend L1[1]!L1[2:0] + every i := 1 to *L do { + if not(L1[i] := @L[i]) then { + done[i] := 0 + if !done = 1 then { + L[i] := ^L[i] + L1[i] := @L[i] | fail + } + else fail + } + } + } +end + +procedure DecimatePDCO(L) #: PDCO to decimate sequence + local i, j, count + + count := 0 + + while j := @L[2] do { + while i := @L[1] | fail do { + count +:= 1 + if count = j then break next + else suspend i + } + } + +end + +procedure DecimationPDCO(L) #: PDCO to create decimation sequence + local i, count + + count := 0 + + while i := @L[1] do { + count +:= 1 + if i % 2 = 1 then suspend count + } + +end +procedure DecollatePDCO(L) #: PDCO to decollate sequence + local i, j, x + + i := @L[2] | 1 + + i %:= 2 + + j := 0 + + while x := @L[1] do { + j +:= 1 + if j % 2 = i then suspend x + } + +end + +procedure DeltaPDCO(L) #: PDCO to generate difference sequence + local i, j + + i := @L[1] | fail + + while j := @L[1] do { + suspend j - i + i := j + } + +end + +procedure ElevatePDCO(L) #: PDCO to elevate sequence + local n, m, shafts, i, j, k + + m := @L[2] | fail + n := @L[3] | fail + + shafts := list(m) + + every !shafts := [] + + every i := 1 to m do + every put(shafts[i], i to n by m) + + while j := @L[1] do { + i := j % m + 1 + k := get(shafts[i]) + suspend k + put(shafts[i], k) + } + +end + +procedure EveryPDCO(L) #: PDCO to model iteration + + while @L[1] do @^L[2] + +end + +procedure ExtendSeqPDCO(L) #: PDCO to extend sequence + local count + + count := integer(@L[2]) | fail + if count < 1 then fail + + repeat { + suspend |@L[1] do { + count -:= 1 + if count = 0 then fail + } + if *L[1] == 0 then fail + L[1] := ^L[1] + } + +end + +procedure ExtractAER(L) #: PDAE to extract values + local i, j, n, L1 + + L1 := list(*L/2) + + repeat { + i := 1 + while i < *L do { + n := @L[i] | fail + every 1 to n do + L1[(i + 1)/2] := @L[i + 1] | fail + L[i + 1] := ^L[i + 1] + i +:= 2 + } + suspend L1[1] ! L1[2:0] + } + +end + +procedure FifoAER(L) #: PDAE for reversal of lifo evaluation + local i, L1, j + + L1 := list(*L) + + j := *L + + repeat { + repeat { + if L1[j] := @L[j] + then { + j -:= 1 + (L[j] := ^L[j]) | break + } + else if (j +:= 1) > *L then fail + } + suspend L1[1] ! L1[2:0] + j := 1 + } + +end + +procedure FriendlyPDCO(L) # PDCO for friendly sequences + local mod, state, value + + mod := @L[1] | fail + state := @L[2] + if /state then state := ?mod + + repeat { + suspend state + value := @L[3] | fail + if value % 2 = 0 then state +:= 1 + else state -:= 1 + state := residue(state, mod, 1) + } + +end + +procedure GaltPDCO(L) #: PDCO to concatenate sequences + local C + + every C := !L do + suspend |@C + +end + +procedure GconjPDCO(L) #: PDCO for generalized conjunction + + suspend Gconj_(L,1) + +end + +procedure Gconj_(L,i,v) + + local e + if e := L[i] then { + suspend v:= |@e & Gconj_(L,i + 1,v) + L[i] := ^e + } + else suspend v + +end + +procedure HistoPDCO(L) #: histogram + local limit, results, seq + + limit := @L[2] | 100 + + seq := [] + + while put(seq, @L[1]) + + results := list(max ! seq, 0) + + every results[!seq] +:= 1 + + suspend !results + +end + + +procedure IncreasingPDCO(L) #: PDCO to filter out non-increasing values + local last, current + + last := @L[1] | fail + + suspend last + + while current := @L[1] do { + if current <= last then next + else { + suspend current + last := current + } + } + +end + +procedure IndexPDCO(L) #: PDCO to select terms by position + local i, j, x + + j := @L[2] | fail + + every i := seq() do { # position + x := @L[1] | fail + if j = i then { + suspend x + repeat { + j := @L[2] | fail + if j > i then break + } + } + } + +end + +procedure InterPDCO(L) #: PDCO to interleave sequences + + suspend |@!L + +end + +procedure LcondPDCO(L) #: PDCO for Lisp conditional + local i + + every i := 1 to *L by 2 do + if @L[i] then { + suspend |@L[i + 1] + fail + } + +end + +procedure LengthPDCO(L) #: PDCO to produce length of sequence + local i + + i := 0 + + while @L[1] do i +:= 1 + + return i + +end + +procedure LifoAER(L) #: PDAE for standard lifo evaluation + local i, L1, j + + L1 := list(*L) + + j := 1 + + repeat { + repeat + if L1[j] := @L[j] + then { + j +:= 1 + (L[j] := ^L[j]) | break + } + else if (j -:= 1) = 0 + then fail + suspend L1[1] ! L1[2:0] + j := *L + } + +end + +procedure LimitPDCO(L) #: PDCO to model limitation + local i, x + + while i := @L[2] do { + every 1 to i do + if x := @L[1] then suspend x + else break + L[1] := ^L[1] + } + +end + +procedure ListPDCO(L) #: list from sequence + local limit, result + + limit := @L[2] | 100 + + result := [] + + every put(result, |@L[1]) \ limit + + return result + +end + +procedure LowerTrimPDCO(L) #: lower trimming + local i + + while i := @L[1] do { + i -:= 1 + if i ~= 0 then suspend i + } + +end + +procedure MapPDCO(L) #: PDCO to map values + local maptbl, x + + maptbl := table() + + while x := @L[1] do { + /maptbl[x] := (@L[2] | fail) + suspend maptbl[x] + } + +end + +procedure OddEvenPDCO(L) #: PDCO to force odd/even sequence + local val, val_old + + while val := @L[1] do { + if val % 2 = \val_old % 2 then + suspend val_old + 1 + suspend val + val_old := val + } + +end + +procedure PalinPDCO(L) #: PDCO to produce palindromic sequence + local tail, x + + tail := [] + + while x := @L[1] do { + suspend x + push(tail, x) + } + + every suspend !tail + +end + +procedure ParallelPDCO(L) #: synonym for Inter + + ParallelPDCO := InterPDCO # redefine for next use + + suspend InterPDCO(L) + +end + +procedure ParallelAER(L) #: PDAE for parallel evaluation + local i, L1 + + L1 := list(*L) + + repeat { + every i := 1 to *L do + L1[i] := @L[i] | fail + suspend L1[1] ! L1[2:0] + } + +end + +procedure PatternPalinPDCO(L) #: PDCO to produce pattern palindrome + local tail, x, limit + + tail := [] + + limit := @L[2] | (2 ^ 15) # good enough + + every 1 to limit do { + x := @L[1] | break + suspend x + push(tail, x) + } + + get(tail) + + pull(tail) + + every suspend !tail + +end + +procedure PeriodPDCO(L) #: PDCO for periodic part of sequence + local limit, result + + limit := @L[2] | 300 + + result := [] + + every put(result, |@L[1]) \ limit + + result := repeater(result) + + suspend !result[2] + +end + +procedure PermutePDCO(L) #: PDCO for permutations + local temp1, temp2, chunk, i, x + + repeat { + temp1 := @L[2] | fail + temp2 := [] + every put(temp2, i := 1 to *temp1) + chunk := [] + every 1 to i do + put(chunk, @L[1]) | fail + suspend !lmap(temp1, temp2, chunk) + } + +end + +procedure PivotPDCO(L) #: PDCO to generate pivot points + local current, direction, m, new + + m := @L[2] + /m := 100 + direction := "+" + + current := @L[1] % m | fail + + suspend current + + repeat { + new := @L[1] % m | break + if new = current then next + case direction of { + "+": { + if new > current then { + current := new + next + } + else { + suspend current + current := new + direction := "-" + } + } + "-": { + if new < current then { + current := new + next + } + else { + suspend current + current := new + direction := "+" + } + } + } + + } + + return current + +end + +procedure PositionsPDCO(L) # positions in e of i + local i, count, j + + i := integer(@L[2]) | fail + + count := 0 + + while j := @L[1] do { + count +:= 1 + if j = i then suspend count + } + +end + +procedure PosDiffPDCO(L) # PDCO to generate positions of difference + local i, x, y + + i := 0 + + while x := @L[1] & y := @L[2] do { + i +:= 1 + if x ~=== y then suspend i + } + +end + +procedure RandomPDCO(L) #: PDCO to generate from sequences at random + local x + + while x := @?L do suspend x + +end + +procedure RepaltPDCO(L) #: PDCO to model repeated alternation + local x + + repeat { + suspend |@L[1] + if *L[1] == 0 then fail + L[1] := ^L[1] + } + +end + +procedure ReducePDCO(L) #: PDCO to reduce sequence using binary operation + local op, x + + op := proc(@L[1], 2) | stop("*** invalid operation for Reduce{}") + x := @L[2] | fail + + while x := op(x, @L[3]) + + return x + +end + +procedure RepeatPDCO(L) #: PDCO to repeat sequence + local i, x + + while i := @L[2] do { + if not(i := integer(i)) then stop("*** invalid repetition in Repeat{}") + every 1 to i do { + suspend |@L[1] + L[1] := ^L[1] + } + } + +end + +procedure RemoveDuplPDCO(L) #: PDCO for remove duplicate values in a sequence + local old, new + + old := @L[1] | fail + suspend old + + repeat { + new := @L[1] | fail + if new === old then next + else { + suspend new + old := new + } + } + +end + +procedure ReplPDCO(L) #: PDCO to replicate values in a sequence + local x, i + + i := 1 # default + + while x := @L[1] do { + i := @L[2] + suspend (1 to i) & x + } + +end + +procedure ResumePDCO(L) #: PDCO to model limited iteration + local i + + while i := @L[2] do { + L[1] := ^L[1] + every 1 to i do if @L[1] then @^L[3] else break + } + +end + +procedure ReversePDCO(L) #: PDCO to reverse sequence + local result, limit + + result := [] + + limit := @L[2] + + /limit := 2 ^ 15 # enough + + every 1 to limit do + push(result, @L[1]) | break + + suspend !result + +end + +procedure RotatePDCO(L) #: PDCO to rotate sequence + local result, i, x + + i := integer(@L[2]) | stop("*** invalid specification in Rotate{}") + + result := [] + + if i <= 0 then { # if not to right, works for infinite sequence + every 1 to -i do + put(result, @L[1]) | break + while x := @L[1] do + suspend x + suspend !result + } + + else { + while put(result, @L[1]) + suspend !lrotate(result, i) + } + +end + +procedure SelfreplPDCO(L) #: PDCO to produce multiple of values in sequence + local i, j + + j := @L[2] | 1 + j := integer(j) | stop("*** invalid second argument to Selfrepl{}") + + while i := @L[1] do { + i := integer(i) | stop("*** invalid value in Selfrepl{}") + suspend (1 to i * j) & i + } + +end + +procedure SeqlistPDCO(L) #: PDCO to return list of values + local result, limit + + result := [] + + limit := @L[2] | 2 ^ 15 # crude ... + + every 1 to limit do + put(result, @L[1]) | break + + return result + +end + +procedure SimpleAER(L) #: PDAE for simple evaluation + local i, L1 + + L1 := list(*L) + + every i := 1 to *L do + L1[i] := @L[i] | fail + + return L1[1] ! L1[2:0] + +end + +procedure SkipPDCO(L) #: PDCO to skip terms + local gap + + suspend @L[1] + + repeat { + gap := @L[2] | fail + every 1 to gap do + @L[1] | fail + suspend @L[1] + } + +end + +procedure SmodPDCO(L) #: generalized modular reduction + local i, m + + while i := @L[1] do { + m := @L[2] | fail + suspend residue(i, m, 1) + } + +end + +procedure SpanPDCO(L) #: fill in gaps in integer sequences + local i, j, m + + j := @L[1] | fail + + m := @L[2] + /m := 100 + + while i := residue(@L[1], m, 1) do { + if i > j then suspend j to i - 1 + else if i < j then suspend j to i + 1 by -1 + j := i + } + + suspend j + +end + +procedure SumlimitPDCO(L) #: PDCO to sum sequence to a limit + local sum, min, limit, i + + limit := integer(@L[2]) | 2 ^ 15 + min := integer(@L[3]) | 0 + sum := 0 + + while i := @L[1] do { + if i < min then next + if (sum + i) > limit then fail + sum +:= i + suspend i + } + +end + +procedure TrinopPDCO(L) #: PDCO to apply trinary operator to sequences + local op, x, y, z + + repeat { + op := proc(@L[1], 3) | fail + x := @L[2] & y := @L[3] & z := @L[4] | fail + suspend op(x, y, z) + } + +end + +procedure UndulantPDCO(L) #: PDCO to produce undulant + local i, j, dir + + i := @L[1] | fail + + suspend i # first value always is in undulant + + j := i # last term in undulant + + while i := @L[1] do { # get initial direction + if i > j then { + dir := -1 + break + } + else if i < j then { + dir := 1 + break + } + } + + j := i + + while i := @L[1] do { + if i < j then { + if dir = -1 then { + suspend j + j := i + dir := 1 + } + else j := i + } + if i > j then { + if dir = 1 then { + suspend j + j := i + dir := -1 + } + else j := i + } + } + + fail + +end + +procedure UniquePDCO(L) #: PDCO to filter out duplication values + local done, x + + done := set() + + while x := @L[1] do + if member(done, x) then next + else { + insert(done, x) + suspend x + } + +end + +procedure UnopPDCO(L) #: PDCO to apply unary operation to sequence + local op, x + + repeat { + op := @L[1] + op := proc(op, 1) | fail + x := @L[2] | fail + suspend op(x) + } + +end + +procedure UpperTrimPDCO(L) #: upper sequence trimming + local done, i + + done := set() + + while i := @L[1] do { + if not member(done, i) then + insert(done, i) + else suspend i + } + +end + +procedure ValrptPDCO(L) #: synonym for Repl + + ValrptPDCO := ReplPDCO + + suspend ReplPDCO(L) + +end + +procedure WobblePDCO(L) #: PDCO to produce sequence values alternately + local x, y + + x := @L[1] | fail + suspend x + + while y := @L[1] do { + suspend y | x | y + x := y + } + +end diff --git a/ipl/procs/periodic.icn b/ipl/procs/periodic.icn new file mode 100644 index 0000000..d9a180a --- /dev/null +++ b/ipl/procs/periodic.icn @@ -0,0 +1,186 @@ +############################################################################ +# +# File: periodic.icn +# +# Subject: Procedures related to periodic sequences +# +# Author: Ralph E. Griswold +# +# Date: June 10, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Sqrt(i, j) produces a rational approximation to the square root of i +# with j iterations of the half-way method. j defaults to 5. +# +############################################################################ +# +# Requires: Large-integer arithmetic +# +############################################################################ +# +# Links: lists, numbers, rational, strings +# +############################################################################ + +link lists +link numbers +link rational +link strings + +record perseq(pre, rep) + +procedure Sqrt(i, j) #: rational approximate to square root + local rat, half + + /j := 5 + + half := rational(1, 2, 1) + + rat := rational(integer(sqrt(i)), 1, 1) # initial approximation + + i := rational(i, 1, 1) + + every 1 to j do + rat := mpyrat(half, addrat(rat, divrat(i, rat, 1), 1)) + + return rat + +end + +procedure rat2cf(rat) #: continued fraction sequence for rational + local r, result, i, j + + i := rat.numer + j := rat.denom + + result := [] + + repeat { + put(result, rational(integer(i / j), 1, 1).numer) + r := i % j + i := j + j := r + if j = 0 then break + } + + return perseq(result, []) + +end + +procedure cfapprox(lst) #: continued-fraction approximation + local prev_n, prev_m, n, m, t + + lst := copy(lst) + + prev_n := [1] + prev_m := [0, 1] + + put(prev_n, get(lst).denom) | fail + + while t := get(lst) do { + n := t.denom * get(prev_n) + t.numer * prev_n[1] + m := t.denom * get(prev_m) + t.numer * prev_m[1] + suspend rational(n, m, 1) + put(prev_n, n) + put(prev_m, m) + if t.denom ~= 0 then { # renormalize + every !prev_n /:= t.denom + every !prev_m /:= t.denom + } + } + +end + +procedure dec2rat(pre, rep) #: convert repeating decimal to rational + local s + + s := "" + + every s ||:= (!pre | |!rep) \ (*pre + *rep) + + return ratred(rational(s - left(s, *pre), + 10 ^ (*pre + *rep) - 10 ^ *pre, 1)) + +end + +procedure rat2dec(rat) #: decimal expansion of rational + local result, remainders, count, seq + + rat := copy(rat) + + result := "" + + remainders := table() + + rat.numer %:= rat.denom + rat.numer *:= 10 + + count := 0 + + while rat.numer > 0 do { + count +:= 1 + if member(remainders, rat.numer) then { # been here; done that + seq := perseq() + result ? { + seq.pre := move(remainders[rat.numer] - 1) + seq.rep := tab(0) + } + return seq + } + else insert(remainders, rat.numer, count) + result ||:= rat.numer / rat.denom + rat.numer %:= rat.denom + rat.numer *:= 10 + } + + return perseq([rat.denom], []) # WRONG!!! + +end + +procedure repeater(seq, ratio, limit) #: find repeat in sequence + local init, i, prefix, results, segment, span + + /ratio := 2 + /limit := 0.75 + + results := copy(seq) + + prefix := [] + + repeat { + span := *results / ratio + every i := 1 to span do { + segment := results[1+:i] | next + if lequiv(lextend(segment, *results), results) then + return perseq(prefix, segment) + } + put(prefix, get(results)) | # first term to prefix + return perseq(prefix, results) + if *prefix > limit * *seq then return perseq(seq, []) + } + +end + +procedure seqimage(seq) #: sequence image + local result + + result := "" + + every result ||:= !seq.pre || "," + + result ||:= "[" + + if *seq.rep > 0 then { + every result ||:= !seq.rep || "," + result[-1] := "]" + } + else result ||:= "]" + + return result + +end diff --git a/ipl/procs/permutat.icn b/ipl/procs/permutat.icn new file mode 100644 index 0000000..8d4f98c --- /dev/null +++ b/ipl/procs/permutat.icn @@ -0,0 +1,90 @@ +############################################################################ +# +# File: permutat.icn +# +# Subject: Procedures for permutations +# +# Author: Ralph E. Griswold +# +# Date: June 10, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Links: lists, seqops +# +############################################################################ + +link lists +link seqops + +procedure multireduce(i, j) #: multi-reduction permutation + local indexes, result, parts + + /j := 2 + + indexes := [] + + every put(indexes, 1 to j) + + parts := ldecollate(indexes, srun(1, i)) + + result := [] + + every result |||:= !parts + + return result + +end + +procedure permperiod(p) #: period of permutation + local lengths + + lengths := [] + + every put(lengths, *!cycles(p)) + + return lcml ! lengths + +end + +procedure cycles(p) #: permutation cycles + local indices, cycle, cycles, i + + cycles := [] # list of cycles + + indices := set() + + every insert(indices, 1 to *p) + + repeat { + i := !indices | break + delete(indices, i) + cycle := set() + insert(cycle, i) + repeat { + i := integer(p[i]) + delete(indices, i) + if member(cycle, i) then break # done with cycle + else insert(cycle, i) # new member of cycle + } + put(cycles, sort(cycle)) + } + + return cycles + +end + +procedure mutate(seq, mutation) #: mutate sequence + local result + + result := [] + + every put(result, seq[!mutation]) + + return result + +end diff --git a/ipl/procs/phoname.icn b/ipl/procs/phoname.icn new file mode 100644 index 0000000..6f9a616 --- /dev/null +++ b/ipl/procs/phoname.icn @@ -0,0 +1,61 @@ +############################################################################ +# +# File: phoname.icn +# +# Subject: Procedures to generate letters for phone numbers +# +# Author: Thomas R. Hicks +# +# Date: June 10, 1988 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure generates the letter combinations corresponding to the +# digits in a telephone number. +# +# Warning: +# +# The number of possibilities is very large. This procedure should be +# used in a context that limits or filters its output. +# +############################################################################ + +procedure phoname(number) + + local buttons, nondigits, pstr, t, x + + + buttons := ["000","111","abc","def","ghi","jkl","mno", "prs","tuv","wxy"] + nondigits := ~&digits + + pstr := stripstr(number,nondigits) + + if 7 ~= *pstr then fail + t := [] + every x := !pstr do + put(t,buttons[x+1]) + + suspend !t[1] || !t[2] || !t[3] || !t[4] || !t[5] || !t[6] || !t[7] + +end + +procedure stripstr(str,delchs) + + local i + + i := 1 + while i <= *str do + { + if any(delchs,str,i) then + str[i] := "" + else + i +:= 1 + } + + return str + +end # stripstr diff --git a/ipl/procs/plural.icn b/ipl/procs/plural.icn new file mode 100644 index 0000000..583c7cf --- /dev/null +++ b/ipl/procs/plural.icn @@ -0,0 +1,65 @@ +############################################################################ +# +# File: plural.icn +# +# Subject: Procedures to produce plural of English noun +# +# Author: Ralph E. Griswold +# +# Date: July 15, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure produces the plural form of a singular English noun. +# The procedure here is rudimentary and does not work in all cases. +# +############################################################################ + +procedure plural(word) #: produce plural of word + local lcword + static plural_map, plural_id, plural_s + + initial { + plural_map := table() + plural_map["mouse"] := "mice" + plural_map["louse"] := "lice" + plural_map["goose"] := "geese" + plural_map["datum"] := "data" + + plural_id := set() + every insert(plural_id,"chassis" | "fish" | "sheep" | "semantics") + + plural_s := set() + every insert(plural_s,"roman" | "norman" | "human" | "shaman" | + "german" | "talisman" | "superhuman") + } + + lcword := map(word) + + if member(plural_id,lcword) then return word + + if member(plural_s,lcword) then return word || "s" + + (lcword := \plural_map[lcword]) | { + lcword ?:= { + (tab(-3) || (match("man") & "men")) | + (tab(-3) || (match("sis") & "ses")) | + (tab(-2) || =("ch" | "sh" | "ss") || "es") | + (tab(-3) || (="tus" & "ti")) | + (tab(-2) || tab(any('cbdghmnprstvxz')) || (match("y") & "ies")) | + (tab(-1) || tab(any('xz')) || "es") | + (tab(0) || "s") + } + } + + if word ? any(&ucase) then lcword ?:= { + map(move(1),&lcase,&ucase) || tab(0) + } + + return lcword + +end diff --git a/ipl/procs/polynom.icn b/ipl/procs/polynom.icn new file mode 100644 index 0000000..eea9ace --- /dev/null +++ b/ipl/procs/polynom.icn @@ -0,0 +1,285 @@ +############################################################################ +# +# File: polynom.icn +# +# Subject: Procedures to manipulate multi-variate polynomials +# +# Author: Ralph E. Griswold +# +# Date: October 1, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# The format for strings omits symbols for multiplication and +# exponentiation. For example, 3*a^2 is entered as 3a2. +# +# A polynomial is represented by a table in which each term, such as 3xy, +# the xy is # a key and the corresponding value is the coefficient, 3 in +# this case. If a variable is raised to a power, such as x^3, the key +# is the product of the individual variables, xxx in this case. +# +############################################################################ +# +# Links: strings, tables +# +############################################################################ + +link strings +link tables + +procedure str2poly(str) #: convert string to polynomial + local poly, var, vars, term, factor, power + + poly := table(0) + + str ? { + while term := (move(1) || tab(upto('-+') | 0)) do { # possible sign + term ? { + factor := 1 # default + factor := tab(many(&digits ++ '+.-')) + tab(0) ? { + vars := "" + while var := move(1) do { + power := 1 # default + power := integer(tab(many(&digits))) + vars ||:= repl(var, power) + } + } + poly[csort(vars)] +:= numeric(factor) | fail + } + } + } + + return poly + +end + +procedure polyadd(poly1, poly2) #: add polynomials + local poly, keys, k + + keys := sort(set(keylist(poly1)) ++ set(keylist(poly2))) + + poly := table(0) + + every k := !keys do + poly[k] := poly1[k] + poly2[k] + + return poly + +end + +procedure polymod(poly, i) #: polynomial modular reduction + local poly1, keys, k + + keys := keylist(poly) + + poly1 := table(0) + + every k := !keys do + poly1[k] := poly[k] % i + + return poly1 + +end + +procedure polysub(poly1, poly2) #: subtract polynomials + local poly, keys, k + + keys := sort(set(keylist(poly1)) ++ set(keylist(poly2))) + + poly := table(0) + + every k := !keys do + poly[k] := poly1[k] - poly2[k] + + return poly + +end + +procedure polymul(poly1, poly2) #: multiply polynomials + local poly, keys1, keys2, k1, k2 + + keys1 := keylist(poly1) + keys2 := keylist(poly2) + + poly := table(0) + + every k1 := !keys1 do + every k2 := !keys2 do + poly[csort(k1 || k2)] +:= poly1[k1] * poly2[k2] + + return poly + +end + +procedure polyexp(poly1, i) #: exponentiate polynomial + local poly + + poly := copy(poly1) + + every 1 to i - 1 do + poly := polymul(poly, poly1) + + return poly + +end + +procedure poly2str(poly) #: polynomial to string + local str, keys, k, count, var + + keys := keylist(poly) + + str := "" + + every k := !keys do { + if poly[k] = 0 then next # skip term + else if poly[k] > 0 then str ||:= "+" || ((poly[k] ~= 1) | "") + else if poly[k] < 0 then str ||:= ((poly[k] ~= 1) | "") + k ? { + while var := move(1) do { + count := 1 + count +:= *tab(many(var)) + if count = 1 then str ||:= var + else str ||:= var || count + } + } + } + + return str[2:0] | "0" + +end + +procedure polydiff(poly, var) #: polynomial differentiation + local poly_new, keys, k, nvars, newk + + poly_new := table() + + keys := keylist(poly) + + every k := !keys do { + k ? { + if newk := tab(upto(var)) then { + nvars := *tab(many(var)) + newk ||:= repl(var, nvars - 1) || tab(0) + poly_new[newk] := nvars * poly[k] + } + } + } + + return poly_new + +end + +procedure polyintg(poly, var) #: polynomial integration + local poly_new, keys, k, nvars, newk + + poly_new := table() + + keys := keylist(poly) + + every k := !keys do { + k ? { + if newk := tab(upto(var)) then { + nvars := *tab(many(var)) + newk ||:= repl(var, nvars + 1) || tab(0) + poly_new[newk] := poly[k] / real(nvars + 1) + } + } + } + + return poly_new + +end + +procedure peval(str) #: string polynomial simplification + + while str ?:= 2(="(", tab(bal(')')), =")", pos(0)) + + return poper(str) | str2poly(str) + +end + +procedure poper(str) #: find polynomial operation + + return str ? { + pform(tab(bal('-+*^:|%')), move(1), tab(0)) + } + +end + +procedure pform(str1, op, str2) #: polynomial formation + + return case op of { + "+" : polyadd(peval(str1), peval(str2)) + "-" : polysub(peval(str1), peval(str2)) + "*" : polymul(peval(str1), peval(str2)) + "^" : polyexp(peval(str1), str2) + ":" : polydiff(peval(str1), str2) + "|" : polyintg(peval(str1), str2) + "%" : polymod(peval(str1), str2) + } + +end + +procedure poly2profile(poly) #: polynomial to profile sequence + local str, keys, k, count, vara, i, seg + + keys := keylist(poly) + + str := "" + + every k := !keys do { + i := poly[k] + if i < 0 then { # if negative, reverse sequence + i := abs(i) + k := reverse(k) + } + str ||:= left(repl(k, i + 1), i * *k) + } + + return str + +end + +procedure poly2profilelen(poly) #: polynomial to profile sequence + local i, keys, k, count, var + + keys := keylist(poly) + + i := 0 + + every k := !keys do + i +:= *repl(k, abs(poly[k])) # treat negative as if positive + + return i + +end + +procedure basepolystr(clist, plist) # base polynomial string + + return "(" || poly2str(basepoly(clist, plist)) || ")" + +end + +procedure basepoly(clist, plist) # base polynomial + local poly, i, c, p + static vlist + + initial vlist := string(&lcase) + + poly := table() + + i := 1 + + while c := get(clist) & p := get(plist) do { + poly[repl(vlist[i], (0 <= p))] := (0 ~= c) + i +:= 1 + } + + return poly + +end diff --git a/ipl/procs/polyseq.icn b/ipl/procs/polyseq.icn new file mode 100644 index 0000000..fd073ae --- /dev/null +++ b/ipl/procs/polyseq.icn @@ -0,0 +1,64 @@ +############################################################################ +# +# File: polyseq.icn +# +# Subject: Procedure to generate Dietz sequence +# +# Author: Ralph E. Griswold +# +# Date: September 19, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# The procedure poly2seq(str) generates the Dietz sequence for the +# polynomial str. See Ada Dietz, "Algebraic Expressions in Handweaving". +# +############################################################################ +# +# Links: polynom, strings +# +############################################################################ + +link polynom +link strings + +procedure poly2seq(str) + local vars + + str := deletec(str, ' ') # delete blanks + + vars := &letters ** cset(str) + + suspend !map(poly2profile(eval(str)), vars, &digits[2+:*vars]) + +end + +procedure eval(str) + + while str ?:= 2(="(", tab(bal(')')), =")", pos(0)) + + return oper(str) | str2poly(str) + +end + +procedure oper(str) + + return str ? form(tab(bal('-+*^%')), move(1), tab(0)) + +end + +procedure form(str1, op, str2) + + return case op of { + "+" : polyadd(eval(str1), eval(str2)) + "-" : polysub(eval(str1), eval(str2)) + "*" : polymul(eval(str1), eval(str2)) + "^" : polyexp(eval(str1), str2) + "%" : polymod(eval(str1), str2) + } + +end diff --git a/ipl/procs/polystuf.icn b/ipl/procs/polystuf.icn new file mode 100644 index 0000000..5c417ea --- /dev/null +++ b/ipl/procs/polystuf.icn @@ -0,0 +1,151 @@ +############################################################################ +# +# File: polystuf.icn +# +# Subject: Procedures for manipulating polynomials +# +# Author: Erik Eid +# +# Date: May 23, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures are for creating and performing operations on single- +# variable polynomials (like ax^2 + bx + c). +# +# poly (c1, e1, c2, e2, ...) - creates a polynomial from the parameters +# given as coefficient-exponent pairs: +# c1x^e1 + c2x^e2 + ... +# is_zero (n) - determines if n = 0 +# is_zero_poly (p) - determines if a given polynomial is 0x^0 +# poly_add (p1, p2) - returns the sum of two polynomials +# poly_sub (p1, p2) - returns the difference of p1 - p2 +# poly_mul (p1, p2) - returns the product of two polynomials +# poly_eval (p, x) - finds the value of polynomial p when +# evaluated at the given x. +# term2string (c, e) - converts one coefficient-exponent pair +# into a string. +# poly_string (p) - returns the string representation of an +# entire polynomial. +# +############################################################################ + +procedure poly (terms[]) +local p, coef, expn + if *terms % 2 = 1 then fail # Odd number of terms means the + # list does not contain all + # coefficient-exponent pairs. + p := table() + while *terms > 0 do { # A polynomial is stored as a + coef := get(terms) # table in which the keys are + expn := get(terms) # exponents and the elements are + # coefficients. + if numeric(coef) then if numeric(expn) + then p[real(expn)] := coef # If any part of pair is invalid, + # discard it. Otherwise, save + # term with a real key (necessary + # for consistency in sorting). + } + return p +end + +procedure is_zero (n) + if ((n = integer(n)) & (n = 0)) then return else fail +end + +procedure is_zero_poly (p) + if ((*p = 1) & is_zero(p[real(0)])) then return else fail +end + +procedure poly_add (p1, p2) +local p3, z + p3 := copy(p1) # Make a copy to start with. + if is_zero_poly (p3) then delete (p3, real(0)) + # If first is zero, don't include + # the 0x^0 term. + every z := key(p2) do { # For every term in the second + if member (p3, z) then p3[z] +:= p2[z] # polynomial, if one of its + else p3[z] := p2[z] # exponent is in the third, + # increment its coefficient. + # Otherwise, create a new term. + if is_zero(p3[z]) then delete (p3, z) + # Remove any term with coefficient + # zero, since the term equals 0. + } + if *p3 = 0 then p3[real(0)] := 0 # Empty poly table indicates a + # zero polynomial. + return p3 +end + +procedure poly_sub (p1, p2) +local p3, z + p3 := copy(p1) # Similar process to poly_add. + if is_zero_poly (p3) then delete (p3, real(0)) + every z := key(p2) do { + if member (p3, z) then p3[z] -:= p2[z] + else p3[z] := -p2[z] + if is_zero(p3[z]) then delete (p3, z) + } + if *p3 = 0 then p3[real(0)] := 0 + return p3 +end + +procedure poly_mul (p1, p2) +local p3, c, e, y, z + p3 := table() + every y := key(p1) do # Multiply every term in p1 by + every z := key(p2) do { # every term in p2 and add those + c := p1[y] * p2[z] # results into p3 as in poly_add. + e := y + z + if member (p3, e) then p3[e] +:= c + else p3[e] := c + if is_zero(p3[e]) then delete (p3, e) + } + if *p3 = 0 then p3[real(0)] := 0 + return p3 +end + +procedure poly_eval (p, x) +local e, sum + sum := 0 + every e := key(p) do # Increase sum by coef * x ^ exp. + sum +:= p[e] * (x ^ e) # Note: this procedure does not + # check in advance if x^e will + # result in an error. + return sum +end + +procedure term2string (c, e) +local t + t := "" + if e = integer(e) then e := integer(e) # Removes unnecessary ".0" + if c ~= 1 then { + if c = -1 then t ||:= "-" else t ||:= c + } # Use "-x" or "x," not "-1x" or + # "1x." + else if e = 0 then t ||:= c # Make sure to include a + # constant term. + if e ~= 0 then { + t ||:= "x" + if e ~= 1 then t ||:= ("^" || e) # Use "x," not "x^1." + } + return t +end + +procedure poly_string (p) +local pstr, plist, c, e + pstr := "" + plist := sort(p, 3) # Sort table into key-value pairs. + while *plist > 0 do { + c := pull(plist) # Since sort is nondecreasing, + e := pull(plist) # take terms in reverse order. + pstr ||:= (term2string (c, e) || " + ") + } + pstr := pstr[1:-3] # Remove last " + " from end + return pstr +end + diff --git a/ipl/procs/popen.icn b/ipl/procs/popen.icn new file mode 100644 index 0000000..4ceb0b2 --- /dev/null +++ b/ipl/procs/popen.icn @@ -0,0 +1,86 @@ +############################################################################ +# +# File: popen.icn +# +# Subject: Procedures for pipes +# +# Author: Ronald Florence +# +# Date: September 28, 1992 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.0 +# +############################################################################ +# +# Contents: +# +# popen(command, mode) +# mode == "w" writes to a pipe +# mode == "r" reads from a pipe +# +# pclose(pipe) +# +# On systems without real pipes (ms-dos), popen and pclose imitate +# pipes; pclose must be called after popen. The code should run +# faster on ms-dos if dir in tempfile() points to a directory on a +# virtual disk. +# +# On systems with real pipes, popen & pclose open and close a pipe. +# +############################################################################ + +global PIPE_cmd, PIPE_fname + +procedure popen(cmd, mode) + local tfn, p + + initial ("pipes" == &features) | { + PIPE_cmd := table() + PIPE_fname := table() + } + (type(PIPE_fname) ~== "table") & return open(cmd, mode || "p") + tfn := tempfile("pipe.") + upto('r', mode) & system(cmd || " > " || tfn) + p := open(tfn, mode) + PIPE_fname[p] := tfn + upto('w', mode) & PIPE_cmd[p] := cmd + return p +end + + +procedure pclose(pipe) + local status + + (type(PIPE_fname) ~== "table") & return close(pipe) + if \PIPE_cmd[pipe] then { + close(pipe) + PIPE_cmd[pipe] ||:= " < " || PIPE_fname[pipe] + status := system(PIPE_cmd[pipe]) + } + else status := close(pipe) + remove(PIPE_fname[pipe]) + PIPE_cmd[pipe] := PIPE_fname[pipe] := &null + return status +end + + # Richard Goerwitz's ever-useful generator. + +procedure tempfile(template) + local temp_name + static dir + + initial { + if "UNIX" == &features then dir := "/tmp/" + else dir := "" + } + every temp_name := dir || template || right(1 to 999,3,"0") do { + close(open(temp_name)) & next + suspend \temp_name + } +end diff --git a/ipl/procs/pqueue.icn b/ipl/procs/pqueue.icn new file mode 100644 index 0000000..44071ac --- /dev/null +++ b/ipl/procs/pqueue.icn @@ -0,0 +1,108 @@ +############################################################################ +# +# File: pqueue.icn +# +# Subject: Procedures for manipulating priority queues +# +# Authors: William S. Evans and Gregg M. Townsend +# +# Date: May 3, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures manipulate priority queues. +# +# pq(L) returns a priority queue containing the elements +# in L. L is a list (or table or set) of pqelem +# records, each containing a data and priority field. +# If L is &null, pq() returns an empty priority queue. +# +# pqget(Q) returns and removes the highest priority element +# from Q. Q is a priority queue returned by pq(). +# +# pqput(Q, e) adds element e (a pqelem record) to Q. +# +# pqgen(Q) generates the elements in Q in priority order. +# +# pqelem(d, p) constructs a record with data d and priority p. +# +############################################################################ +# +# Priority queues are implemented as heaps. Heaps are +# implemented as lists in the usual fashion. +# +############################################################################ + +record pqelem ( + data, # element's data + priority # element's priority + ) + +procedure pq(L) #: create priority queue + local Q, i, e + + /L := list() + Q := list() + every e := !L do + put(Q, pqelem(e.data, numeric(e.priority) | runerr(102, e.priority))) + every i := *Q / 2 to 1 by -1 do + pq__down(Q, i) + return Q +end + +procedure pqget(Q) #: remove first priority queue element + local e + + e := get(Q) | fail + push(Q, pull(Q)) + pq__down(Q, 1) + return e +end + +procedure pqgen(Q) #: generate priority queue elements + local q, e + + q := copy(Q) + while e := copy(pqget(q)) do + suspend e +end + +procedure pqput(Q, e) #: insert priority queue element + put(Q, pqelem(e.data, numeric(e.priority) | runerr(102, e.priority))) + pq__up(Q, *Q) + return Q +end + +# Procedures named with a "pq__" prefix are not +# intended for access outside this file. + +procedure pq__down(Q, i) + local left, right, largest + + left := i * 2 + right := left + 1 + + if Q[left].priority > Q[i].priority then largest := left + else largest := i + if Q[right].priority > Q[largest].priority then largest := right + if largest ~= i then { + Q[i] :=: Q[largest] + pq__down(Q, largest) + } + return +end + +procedure pq__up(Q, i) + local parent + + parent := i / 2 + if Q[i].priority > Q[parent].priority then { + Q[i] :=: Q[parent] + pq__up(Q, parent) + } + return +end diff --git a/ipl/procs/printcol.icn b/ipl/procs/printcol.icn new file mode 100644 index 0000000..0205747 --- /dev/null +++ b/ipl/procs/printcol.icn @@ -0,0 +1,149 @@ +############################################################################ +# +# File: printcol.icn +# +# Subject: Procedure to format columnar data +# +# Author: Robert J. Alexander +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure deals with with the problem of printing tabular +# data where the total width of items to be printed is wider than +# the page. Simply allowing the data to wrap to additional lines +# often produces marginally readable output. This procedure facil- +# itates printing such groups of data as vertical columns down the +# page length, instead of as horizontal rows across the page. That +# way many, many fields can be printed neatly. The programming of +# such a transformation can be a nuisance. This procedure does +# much of the work for you, like deciding how many items can fit +# across the page width and ensuring that entire items will be +# printed on the same page without page breaks (if that service is +# requested). +# +############################################################################ +# +# For example, suppose we have a list of records we would like +# to print. The record is defined as: +# +# record rec(item1,item2,item3,...) +# +# Also suppose that lines such as +# +# Field 1 Field 2 Field 3 ... +# ------- ------- ------- --- +# Record 1 item1 item2 item3 ... +# Record 2 item1 item2 item3 ... +# +# are too long to print across the page. This procedure will print +# them as: +# +# TITLE +# ===== +# Record 1 Record 2 ... +# -------- -------- --- +# Field 1 item1 item1 ... +# Field 2 item2 item2 ... +# Field 3 item3 item3 ... +# +# The arguments are: +# +# items: a co-expression that produces a sequence of +# items (usually structured data objects, but not +# necessarily) for which data is to be printed. +# +# fields: a list of procedures to produce the field's +# data. Each procedure takes two arguments. The +# procedure's action depends upon what is passed +# in the first argument: +# +# header Produces the row heading string to be used +# for that field (the field name). +# +# width Produces the maximum field width that can +# be produced (including the column header). +# +# Other Produces the field value string for the +# item passed as the argument. +# +# The second argument is arbitrary data from the procedures +# with each invocation. The data returned by the first func- +# tion on the list is used as a column heading string (the +# item name). +# +# title: optional. +# +# +# pagelength: if null (omitted) page breaks are ignored. +# +# linelength: default 80. +# +# auxdata: auxiliary arbitrary data to be passed to the field +# procedures -- see `fields', above. +# +############################################################################ + +procedure printcol(items,fields,title,pagelength,linelength,auxdata) + local maxwidth,maxhead,groups,columns,itemlist,cont,f,p,underline, + hfield + /linelength := 80 + /pagelength := 30000 + /title := "" +# +# Compute the maximum field width (so we know the column spacing) and +# the maximum header width (so we know how much space to leave on the +# left for headings. +# + maxwidth := maxhead := -1 + cont := "" + every maxwidth <:= (!fields)("width",auxdata) + hfield := get(fields) + every maxhead <:= *(!fields)("header",auxdata) + columns := (linelength - maxhead) / (maxwidth + 1) + groups := pagelength / (6 + *fields) +# +# Loop to print groups of data. +# + repeat { + if pagelength < 30000 then writes("\f") +# +# Loop to print data of a group (a page's worth). +# + every 1 to groups do { +# +# Collect the items to be output in this group. A group is the number +# of columns that can fit across the page. +# + itemlist := [] + every 1 to columns do put(itemlist,@items) | break + if *itemlist = 0 then break break +# +# Print a title and the column headings. +# + write(repl("=",*write("\n",title || cont))) + cont := " (continued)" + writes(underline := left("",maxhead)) + every f := hfield(!itemlist,auxdata) do { + p := if *f < maxwidth then center else left + writes(" ",p(f,maxwidth)) + underline ||:= " " || p(repl("-",*f),maxwidth) + } + write("\n",underline) +# +# Print the fields. +# + every f := !fields do { + writes(right(f("header",auxdata),maxhead)) + every writes(" ",center(f(!itemlist,auxdata),maxwidth)) + write() + } + } # End of loop to print groups. + } # End of loop to print all items. + return +end diff --git a/ipl/procs/printf.icn b/ipl/procs/printf.icn new file mode 100644 index 0000000..b5f99b9 --- /dev/null +++ b/ipl/procs/printf.icn @@ -0,0 +1,313 @@ +############################################################################ +# +# File: printf.icn +# +# Subject: Procedures for printf-style formatting +# +# Author: William H. Mitchell +# +# Date: July 20, 2005 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Contributors: Cheyenne Wills, Phillip Lee Thomas, Michael Glass +# +############################################################################ +# +# This procedure behaves somewhat like the standard printf. +# Supports d, e, s, o, and x formats like printf. An "r" format +# prints real numbers in a manner similar to that of printf's "f", +# but will produce a result in an exponential format if the number +# is larger than the largest integer plus one. Though "e" differs +# from printf in some details, it always produces exponential format. +# +# Left or right justification and field width control are pro- +# vided as in printf. %s, %r, and %e handle precision specifications. +# +# The %r format is quite a bit of a hack, but it meets the +# author's requirements for accuracy and speed. Code contributions +# for %f, %e, and %g formats that work like printf are welcome. +# +# Possible new formats: +# +# %t -- print a real number as a time in hh:mm +# %R -- roman numerals +# %w -- integers in English +# %b -- binary +# +############################################################################ + +procedure sprintf(format, args[]) + return _doprnt(format, args) +end + +procedure fprintf(file, format, args[]) + writes(file, _doprnt(format, args)) + return +end + +procedure printf(format, args[]) + writes(&output, _doprnt(format, args)) + return +end + +procedure _doprnt(format, args) + local out, v, just, width, conv, prec, pad + + out := "" + format ? repeat { + (out ||:= tab(upto('%'))) | (out ||:= tab(0) & break) + v := get(args) + move(1) + just := right + width := conv := prec := pad := &null + ="-" & just := left + width := tab(many(&digits)) + (\width)[1] == "0" & pad := "0" + ="." & prec := tab(many(&digits)) + conv := move(1) + + ##write("just: ",image(just),", width: ", width, ", prec: ", + ## prec, ", conv: ", conv) + case conv of { + "d": { + v := string(integer(v)) + } + "s": { + v := string(v[1:(\prec+1)|0]) + } + "x": v := hexstr(v) + "o": v := octstr(v) + "i": v := image(v) + "r": v := fixnum(v,prec) + "e": v := eformatstr(v, prec, width) + default: { + push(args, v) + v := conv + } + } + if \width & *v < width then { + v := just(v, width, pad) + } + out ||:= v + } + + return out +end + +procedure hexstr(n) + local h, neg + static BigNeg, hexdigs, hexfix + + initial { + BigNeg := -2147483647-1 + hexdigs := "0123456789abcdef" + hexfix := "89abcdef" + } + + n := integer(n) + if n = BigNeg then + return "80000000" + h := "" + if n < 0 then { + n := -(BigNeg - n) + neg := 1 + } + repeat { + h := hexdigs[n%16+1]||h + if (n /:= 16) = 0 then + break + } + if \neg then { + h := right(h,8,"0") + h[1] := hexfix[h[1]+1] + } + return h +end +procedure octstr(n) + local h, neg + static BigNeg, octdigs, octfix + + initial { + BigNeg := -2147483647-1 + octdigs := "01234567" + octfix := "23" + } + + n := integer(n) + if n = BigNeg then + return "20000000000" + h := "" + if n < 0 then { + n := -(BigNeg - n) + neg := 1 + } + repeat { + h := octdigs[n%8+1]||h + if (n /:= 8) = 0 then + break + } + if \neg then { + h := right(h,11,"0") + h[1] := octfix[h[1]+1] + } + return h +end + +procedure fixnum(x, prec) + local int, frac, f1, f2, p10 + + /prec := 6 + x := real(x) | return image(x) + int := integer(x) | return image(x) + frac := image(x - int) + if find("e", frac) then { + frac ?:= { + f1 := tab(upto('.')) & + move(1) & + f2 := tab(upto('e')) & + move(1) & + p10 := -integer(tab(0)) & + repl("0",p10-1) || f1 || f2 + } + } + else + frac ?:= (tab(upto('.')) & move(1) & tab(0)) + frac := adjustfracprec(frac, prec) + int +:= if int >= 0 then frac[2] else -frac[2] + return int || "." || frac[1] +end + + +# e-format: [-]m.dddddde(+|-)xx +# +# Differs from C and Fortran E formats primarily in the +# details, among them: +# +# - Single-digit exponents are not padded out to two digits. +# +# - The precision (number of digits after the decimal point) +# is reduced if needed to make the number fit in the available +# width, if possible. The precision is never reduced-to-fit +# below 1 digit after the decimal point. +# +procedure eformatstr(x, prec, width) + local signpart, wholepart, fracpart, exppart + local choppart, shiftcount, toowide + local rslt, s + + /prec := 6 + /width := prec + 7 + + # Separate string representation of x into parts + # + s := string(real(x)) | return image(x) + s ? { + signpart := (=("-" | "+") | "") + wholepart := 1(tab(many(&digits)), any('.eE')) | return image(x) + fracpart := ((=".", tab(many(&digits))) | "") + exppart := integer((=("e"|"E"), tab(0)) | 0) + } + + # When the integer part has more than 1 digit, shift it + # right into fractional part and scale the exponent + # + if *wholepart > 1 then { + exppart +:= *wholepart -1 + fracpart := wholepart[2:0] || fracpart + wholepart := wholepart[1] + } + + # If the the number is unnormalized, shift the fraction + # left into the whole part and scale the exponent + # + if wholepart == "0" then { + if shiftcount := upto('123456789', fracpart) then { + exppart -:= shiftcount + wholepart := fracpart[shiftcount] + fracpart := fracpart[shiftcount+1:0] + } + } + + # Adjust the fractional part to the requested precision. + # If the carry causes the whole part to overflow from + # 9 to 10 then renormalize. + # + fracpart := adjustfracprec(fracpart, prec) + wholepart +:= fracpart[2] + fracpart := fracpart[1] + if *wholepart > 1 then { + wholepart := wholepart[1] + exppart +:= 1 + } + + # Assemble the final result. + # - Leading "+" dropped in mantissa + # - Leading "+" obligatory in exponent + # - Decimal "." included iff fractional part is non-empty + # + wholepart := (signpart == "-", "-") || wholepart + exppart := (exppart > 0, "+") || exppart + fracpart := (*fracpart > 0, ".") || fracpart + rslt := wholepart || fracpart || "e" || exppart + + # Return the result. + # -- If too short, pad on the left with blanks (not zeros!). + # -- If too long try to shrink the precision + # -- If shrinking is not possible return a field of stars. + # + return (*rslt <= width, right(rslt, width)) | + (*rslt - width < prec, eformatstr(x, prec + width - *rslt, width)) | + repl("*", width) +end + +# Zero-extend or round the fractional part to 'prec' digits. +# +# Returns a list: +# +# [ fracpart, carry ] +# +# where the fracpart has been adjusted to the requested +# precision, and the carry (result of possible rounding) +# is to be added into the whole number. +# +procedure adjustfracprec(fracpart, prec) + + local choppart, carryout + + # Zero-extend if needed. + if *fracpart < prec then return [left(fracpart, prec, "0"), 0] + + # When the fractional part has more digits than the requested + # precision, chop off the extras and round. + # + carryout := 0 + if *fracpart > prec then { + choppart := fracpart[prec+1:0] + fracpart := fracpart[1+:prec] + + # If rounding up is needed... + # + if choppart[1] >>= "5" then { + + # When the fractional part is .999s or the precision is 0, + # then round up overflows into the whole part. + # + if (prec = 0) | (string(cset(fracpart)) == "9") then { + fracpart := left("0", prec, "0") + carryout := 1 + } + # In the usual case, round up simply increments the + # fractional part. (We put back any trailing + # zeros that got lost.) + else { + fracpart := left(integer(fracpart)+1, prec, "0") + } + } + } + return [fracpart, carryout] +end diff --git a/ipl/procs/prockind.icn b/ipl/procs/prockind.icn new file mode 100644 index 0000000..b64daa8 --- /dev/null +++ b/ipl/procs/prockind.icn @@ -0,0 +1,40 @@ +############################################################################ +# +# File: prockind.icn +# +# Subject: Procedure to indicate kind of procedure +# +# Author: Ralph E. Griswold +# +# Date: January 4, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# prockind(p) produces a code for the kind of the procedure p as follows: +# +# "p" (declared) procedure +# "f" (built-in) function +# "o" operator +# "c" record constructor +# +# It fails if p is not of type procedure. +# +############################################################################ + +procedure prockind(p) + + if type(p) ~== "procedure" then fail + + image(p) ? { + if find("procedure") then return "p" + if find("record constructor") then return "c" + ="function " + if upto(&letters) then return "f" else return "o" + } + +end + diff --git a/ipl/procs/procname.icn b/ipl/procs/procname.icn new file mode 100644 index 0000000..c929b63 --- /dev/null +++ b/ipl/procs/procname.icn @@ -0,0 +1,52 @@ +############################################################################ +# +# File: procname.icn +# +# Subject: Procedure to produce name of procedure +# +# Author: Ralph E. Griswold +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# procname(p, x) produces the name of a procedure from a procedure value. +# Here, the term "procedure" includes functions, operators, and +# record constructors. +# +# If x is null, the result is derived from image() is a relatively +# straightforward way. In the case of operators, the number of +# arguments is appended to the operator symbol. +# +# If x is nonnull, the result is put in a form that resembles an Icon +# expression. +# +# procname() fails if p is not of type procedure. +# +############################################################################ + +procedure procname(p, x) + local result + + image(p) ? { + =("function " | "procedure " | "record constructor ") + if /x then return if any(&letters) then tab(0) else tab(0) || args(p) + else result := tab(0) + if any(&letters, result) then return result || "()" + else return case args(p) of { + 0: result + 1: result || "e" + 2: if result == "[]" then "e1[e2]" else "e1 " || result || " e2" + 3: case result of { + "...": "e1 to e2 by e3" + "[:]": "e1[e2:e3]" + default: "<<< ... " || result || "... >>>" + } + } + } + +end diff --git a/ipl/procs/progary.icn b/ipl/procs/progary.icn new file mode 100644 index 0000000..08213d2 --- /dev/null +++ b/ipl/procs/progary.icn @@ -0,0 +1,31 @@ +############################################################################ +# +# File: progary.icn +# +# Subject: Procedure to place program in a array +# +# Author: Ralph E. Griswold +# +# Date: April 30, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure creates an array with one element for each program token. +# The program is read from file. The initial value of each element is value. +# +############################################################################ + +procedure progary(file, value) + local A + + A := [] + + while put(A, list(*read(file), value)) + + return A + +end diff --git a/ipl/procs/pscript.icn b/ipl/procs/pscript.icn new file mode 100644 index 0000000..a1f22e9 --- /dev/null +++ b/ipl/procs/pscript.icn @@ -0,0 +1,136 @@ +############################################################################ +# +# File: pscript.icn +# +# Subject: Procedure for explicitly writing PostScript +# +# Author: Gregg M. Townsend +# +# Date: February 21, 2003 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This file contains procedures for writing PostScript output explicitly, +# as contrasted with the procedures in psrecord.icn that write PostScript +# as a side effect of normal graphics calls. +# +# epsheader(f, x, y, w, h, flags) writes an Encapsulated PostScript +# file header and initializes the PostScript coordinate system. +# +# psprotect(s) adds escapes to protect characters that are special in +# PostScript strings, notably parentheses and backslash. +# +############################################################################ +# +# epsheader(f, x, y, w, h, flags) aids the creation of an Encapsulated +# PostScript file by writing a header. An EPS file can either be +# incorporated as part of a larger document or sent directly to a +# PostScript printer. +# +# Epsheader() writes the first portion of the PostScript output to file +# f; the calling program then generates the rest. It is the caller's +# responsibility to ensure that the rest of the file conforms to the +# requirements for EPS files as documented in the PostScript Reference +# Manual, second edition. +# +# (x,y,w,h) specify the range of coordinates that are to be used in the +# generated PostScript code. Epsheader() generates PostScript commands +# that center this region on the page and clip anything outside it. +# +# If the flags string contains the letter "r" and abs(w) > abs(h), the +# coordinate system is rotated to place the region in "landscape" mode. +# +# The generated header also defines an "inch" operator that can be used +# for absolute measurements as shown in the example below. +# +# Usage example: +# +# f := open(filename, "w") | stop("can't open ", filename) +# epsheader(f, x, y, w, h) +# write(f, ".07 inch setlinewidth") +# write(f, x1, " ", y1, " moveto ", x2, " ", y2, " lineto stroke") +# ... +# write(f, "showpage") +# +############################################################################ +# +# psprotect(s) adds a backslash character before each parenthesis or +# backslash in s. These characters are special in PostScript strings. +# The characters \n \r \t \b \f are also replaced by escape sequences, +# for readability, although this is not required by PostScript. +# +############################################################################ + +$define PSPoint 72 # PostScript points per inch + +# 8.5x11" paper size parameters -- change these to use A4 or something else +$define PageWidth 8.5 +$define PageHeight 11.0 +$define HorzMargin 0.75 +$define VertMargin 1.0 + +procedure epsheader(f, x, y, w, h, flags) #: write PostScript header + local xctr, yctr, xsize, ysize, xscale, yscale, dx, dy + + if w < 0 then + x -:= (w := -w) + if h < 0 then + y -:= (h := -h) + + xctr := integer(PSPoint * PageWidth / 2) # PS center coordinates + yctr := integer(PSPoint * PageHeight / 2) + xsize := PSPoint * (PageWidth - HorzMargin) # usable width + ysize := PSPoint * (PageHeight - VertMargin) # usable height + if w > h & upto('r', \flags) then + xsize :=: ysize + + xscale := xsize / w + yscale := ysize / h + xscale >:= yscale + yscale >:= xscale + + dx := integer(xscale * w / 2 + 0.99999) + dy := integer(yscale * h / 2 + 0.99999) + if xsize > ysize then + dx :=: dy + + write(f, "%!PS-Adobe-3.0 EPSF-3.0") + write(f, "%%BoundingBox: ", + xctr - dx, " ", yctr - dy, " ", xctr + dx, " ", yctr + dy) + write(f, "%%Creator: ", &progname) + write(f, "%%CreationDate: ", &dateline) + write(f, "%%EndComments") + write(f) + write(f, xctr, " ", yctr, " translate") + if xsize > ysize then + write(f, "90 rotate \n", -dy, " ", -dx, " translate") + else + write(f, -dx, " ", -dy, " translate") + write(f, xscale, " ", yscale, " scale") + write(f, -x, " ", -y, " translate") + write(f, x, " ", y, " moveto ", x, " ", y + h, " lineto ", + x + w, " ", y + h, " lineto ", x + w, " ", y, " lineto ") + write(f, "closepath clip newpath") + write(f, "/inch { ", 72 / xscale, " mul } bind def") + write(f, "1 72 div inch setlinewidth") + write(f) + return +end + +procedure psprotect(s) #: escape special PostScript characters + local t + + s ? { + t := "" + while t ||:= tab(upto('()\\\n\r\t\b\f')) do { + t ||:= "\\" + t ||:= map(move(1), "()\\\n\r\t\b\f", "()\\nrtbf") + } + return t ||:= tab(0) + } + +end diff --git a/ipl/procs/ptutils.icn b/ipl/procs/ptutils.icn new file mode 100644 index 0000000..18f4e73 --- /dev/null +++ b/ipl/procs/ptutils.icn @@ -0,0 +1,74 @@ +############################################################################ +# +# File: ptutils.icn +# +# Subject: Procedures relating to objects in 3-space +# +# Author: Ralph E. Griswold +# +# Date: March 25, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures provide various operations on 3-dimensional objects +# in 3-space. +# +############################################################################ +# +# Links: gobject +# +############################################################################ + +link gobject + +procedure pt2coord(p) #: convert point to coordinate + + return p.x || " " || p.y || " " || p.z + +end + +procedure coord2pt(c) #: convert coordinate to path + local p + + p := Point() + + c ? { + p.x := tab(upto(' ')) + move(1) + p.y := tab(upto(' ')) + move(1) + p.z := tab(0) + } + + return p + +end + +procedure negpt(p) #: negative of point + + return Point(-p.x, -p.y, -p.z) + +end + +procedure pteq(p1, p2) #: test point equality + + if p1.x = p2.x & p1.y = p2.y & p1.z = p2.z then return p2 else fail + +end + +procedure getpts(s) #: make point list from coordinate file + local input, pts + + input := open(s) | stop("*** cannot open ", image(s)) + + pts := [] + + while put(pts, coord2pt(read(input))) + + return pts + +end diff --git a/ipl/procs/random.icn b/ipl/procs/random.icn new file mode 100644 index 0000000..8dc58f2 --- /dev/null +++ b/ipl/procs/random.icn @@ -0,0 +1,180 @@ +############################################################################ +# +# File: random.icn +# +# Subject: Procedures related to random numbers +# +# Authors: Ralph E. Griswold and Gregg M. Townsend +# +# Date: June 24, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This file contains procedures related to pseudo-random numbers. +# +# rand_num() is a linear congruential pseudo-random number +# generator. Each time it is called, it produces +# another number in the sequence and also assigns it +# to the global variable random. With no arguments, +# rand_num() produces the same sequence(s) as Icon's +# built-in random-number generator. Arguments can be +# used to get different sequences. +# +# The global variable random serves the same role that +# &random does for Icon's built-in random number +# generator. +# +# rand_int(i) produces a randomly selected integer in the range 1 +# to i. It models ?i for positive i. +# +# randomize() sets &random to a "random" value, using /dev/urandom +# if available, otherwise based on the date and time. +# +# randrange(min, max) +# produces random number in the range min <= i <= max. +# +# randrangeseq(i, j) +# generates the integers from i to j in random order. +# +# +# randseq(seed) generates the values of &random, starting at seed, +# that occur as the result of using ?x. +# +# rng(a, c, m, x) generates a sequence of numbers using the linear +# congruence method. With appropriate parameters, the +# result is a pseudo-random sequence. The default +# values produce the sequence used in Icon. +# +# shuffle(x) shuffles the elements of x +# +############################################################################ +# +# Links: factors +# +############################################################################ + +link factors + +global random + +procedure rand_num(a_, c_, m_) #: random number generator + static random_last, a, c, m + + initial { + /random := 0 + a := \a_ | 1103515245 + c := \c_ | 453816694 + m := (\m_ | 2 ^ 31) + } + + return random := (a * random + c) % m + +end + +procedure rand_int(i) #: model ?i + static scale + + initial scale := 1.0 / (2 ^ 31 - 1) + + (i := (0 < integer(i))) | runerr(205, i) + + return integer(i * rand_num() * scale) + 1 + +end + +procedure randomize() #: randomize + local f, s + static ncalls + initial ncalls := 0 + + ncalls +:= 1 + + if f := open("/dev/urandom", "ru") then { + s := reads(f, 3) + close(f) + if *\s > 0 then { + &random := ncalls % 113 + every &random := 256 * &random + ord(!s) + return + } + } + + &random := map("sSmMhH", "Hh:Mm:Ss", &clock) + + map("YyXxMmDd", "YyXx/Mm/Dd", &date) + &time + 1009 * ncalls + + return + +end + +procedure randrange(min, max) #: random number in range + + return min - 1 + ?(max - min + 1) + +end + +procedure randrangeseq(i, j) #: random sequence in range + local x, m, a, c, n + + n := j - i + 1 + + if n < 0 then fail + + x := 1 + m := nxtprime(n) + a := m + 1 + c := nxtprime(m) + + every 1 to m do { + x := (a * x + c) % m + if x < n then { # discard out-of-range values + suspend x + i + } + } + +end + +procedure randseq(seed) #: generate &random + + suspend &random := seed + suspend |?1 & &random + +end + +procedure rng(a, c, m, x) #: random number generator + + /a := 1103515245 # multiplicative constant + /c := 453816694 # additive constant + /m := 2 ^ 31 - 1 # modulus + /x := 0 # initial value + + suspend x + suspend x := iand(a * |x + c, m) + +end + +# The procedure shuffle(x) shuffles a string, list, or record. +# In the case that x is a string, a corresponding string with the +# characters randomly rearranged is produced. In the case that x is +# list or records the elements are randomly rearranged. + +procedure shuffle(x) #: shuffle + local i + + x := string(x) # may fail + every i := *x to 2 by -1 do + x[?i] :=: x[i] + return x +end + +# Note: the following procedure is simpler, but does not produce +# as good a shuffle: +# +#procedure shuffle(x) +# x := string(x) +# every !x :=: ?x +# return x +#end diff --git a/ipl/procs/rational.icn b/ipl/procs/rational.icn new file mode 100644 index 0000000..0f3c311 --- /dev/null +++ b/ipl/procs/rational.icn @@ -0,0 +1,220 @@ +############################################################################ +# +# File: rational.icn +# +# Subject: Procedures for arithmetic on rational numbers +# +# Author: Ralph E. Griswold +# +# Date: June 10, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Contributor: Gregg M. Townsend +# +############################################################################ +# +# These procedures perform arithmetic on rational numbers (fractions): +# +# addrat(r1,r2) Add rational numbers r1 and r2. +# +# divrat(r1,r2) Divide rational numbers r1 and r2. +# +# medrat(r1,r2) Form mediant of r1 and r2. +# +# mpyrat(r1,r2) Multiply rational numbers r1 and r2. +# +# negrat(r) Produce negative of rational number r. +# +# rat2real(r) Produce floating-point approximation of r +# +# rat2str(r) Convert the rational number r to its string +# representation. +# +# real2rat(v,p) Convert real to rational with precision p. +# The default precision is 1e-10. +# (Too much precision gives huge, ugly factions.) +# +# reciprat(r) Produce the reciprocal of rational number r. +# +# str2rat(s) Convert the string representation of a rational number +# (such as "3/2") to a rational number. +# +# subrat(r1,r2) Subtract rational numbers r1 and r2. +# +############################################################################ +# +# Links: numbers +# +############################################################################ + +link numbers + +record rational(numer, denom, sign) + +procedure addrat(r1, r2) #: sum of rationals + local denom, numer, div + + r1 := ratred(r1) + r2 := ratred(r2) + + denom := r1.denom * r2.denom + numer := r1.sign * r1.numer * r2.denom + + r2.sign * r2.numer * r1.denom + + if numer = 0 then return rational (0, 1, 1) + + div := gcd(numer, denom) + + return rational(abs(numer / div), abs(denom / div), numer / abs(numer)) + +end + +procedure divrat(r1, r2) #: divide rationals. + + r1 := ratred(r1) + r2 := ratred(r2) + + return mpyrat(r1, reciprat(r2)) + +end + +procedure medrat(r1, r2) #: form rational mediant + local numer, denom, div + + r1 := ratred(r1) + r2 := ratred(r2) + + numer := r1.numer + r2.numer + denom := r1.denom + r2.denom + + div := gcd(numer, denom) + + return rational(numer / div, denom / div, r1.sign * r2.sign) + +end + +procedure mpyrat(r1, r2) #: multiply rationals + local numer, denom, div + + r1 := ratred(r1) + r2 := ratred(r2) + + numer := r1.numer * r2.numer + denom := r1.denom * r2.denom + + div := gcd(numer, denom) + + return rational(numer / div, denom / div, r1.sign * r2.sign) + +end + +procedure negrat(r) #: negative of rational + + r := ratred(r) + + return rational(r.numer, r.denom, -r.sign) + +end + +procedure rat2real(r) #: floating-point approximation of rational + + r := ratred(r) + + return (real(r.numer) * r.sign) / r.denom + +end + +procedure rat2str(r) #: convert rational to string + + r := ratred(r) + + return "(" || (r.numer * r.sign) || "/" || r.denom || ")" + +end + +procedure ratred(r) #: reduce rational to lowest terms + local div + + if r.denom = 0 then runerr(501) + if abs(r.sign) ~= 1 then runerr(501) + + if r.numer = 0 then return rational(0, 1, 1) + + if r.numer < 0 then r.sign *:= -1 + if r.denom < 0 then r.sign *:= -1 + + r.numer := abs(r.numer) + r.denom := abs(r.denom) + + div := gcd(r.numer, r.denom) + + return rational(r.numer / div, r.denom / div, r.sign) + +end + +# real2rat(v, p) -- convert real to rational with precision p +# +# Originally based on a calculator algorithm posted to usenet on August 19, +# 1987, by Joseph D. Rudmin, Duke University Physics Dept. (duke!dukempd!jdr) + +$define MAXITER 40 # maximum number of iterations +$define PRECISION 1e-10 # default conversion precision + +procedure real2rat(r, p) #: convert to rational with precision p + local t, d, i, j + static x, y + initial { x := list(MAXITER); y := list(MAXITER + 2) } + + t := abs(r) + /p := PRECISION + every i := 1 to MAXITER do { + x[i] := integer(t) + y[i + 1] := 1 + y[i + 2] := 0 + every j := i to 1 by -1 do + y[j] := x[j] * y[j + 1] + y[j + 2] + if abs(y[1] / real(y[2]) - r) < p then break + d := t - integer(t) + if d < p then break + t := 1.0 / d + } + return rational(y[1], y[2], if r >= 0 then 1 else -1) + +end + +procedure reciprat(r) #: reciprocal of rational + + r := ratred(r) + + return rational(r.denom, r.numer, r.sign) + +end + +procedure str2rat(s) # convert string to rational + local div, numer, denom, sign + + s ? { + ="(" & + numer := integer(tab(upto('/'))) & + move(1) & + denom := integer(tab(upto(')'))) & + pos(-1) + } | fail + + return ratred(rational(numer, denom, 1)) + +end + +procedure subrat(r1, r2) #: difference of rationals + + r1 := ratred(r1) + r2 := ratred(r2) + + return addrat(r1, negrat(r2)) + +end diff --git a/ipl/procs/readcpt.icn b/ipl/procs/readcpt.icn new file mode 100644 index 0000000..2606be9 --- /dev/null +++ b/ipl/procs/readcpt.icn @@ -0,0 +1,54 @@ +############################################################################ +# +# File: readcpt.icn +# +# Subject: Procedure to read produce "carpet" from file +# +# Author: Ralph E. Griswold +# +# Date: August 7, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure reads a "carpet" file and returns a corresponding matrix. +# +############################################################################ +# +# Links: matrix +# +############################################################################ +# +# See also: writecpt.icn +# +############################################################################ + +link matrix + +procedure read_cpt(input) #: convert numerical carpet to matrix + local carpet, width, height, i, j, line + + read(input) ? { + ="width=" & + width := integer(tab(many(&digits))) & + =" height=" & + height := integer(tab(many(&digits))) + } | stop("*** invalid carpet file") + + carpet := create_matrix(height, width) + + every j := 1 to height do { + line := read(input) | stop("*** short carpet data") + i := 0 + line ? { + while carpet[j, i +:= 1] := tab(upto(' ')) do + move(1) | stop("*** narrow carpet data") + } + } + + return carpet + +end diff --git a/ipl/procs/readtbl.icn b/ipl/procs/readtbl.icn new file mode 100644 index 0000000..d18b138 --- /dev/null +++ b/ipl/procs/readtbl.icn @@ -0,0 +1,88 @@ +############################################################################ +# +# File: readtbl.icn +# +# Subject: Procedures to read user-created stripsgml table +# +# Author: Richard L. Goerwitz +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.1 +# +############################################################################ +# +# This file is part of the strpsgml package. It does the job of read- +# ing option user-created mapping information from a file. The purpose +# of this file is to specify how each code in a given input text should +# be translated. Each line has the form: +# +# SGML-designator start_code end_code +# +# where the SGML designator is something like "quote" (without the quota- +# tion marks), and the start and end codes are the way in which you want +# the beginning and end of a <quote>...<\quote> sequence to be transla- +# ted. Presumably, in this instance, your codes would indicate some set +# level of indentation, and perhaps a font change. If you don't have an +# end code for a particular SGML designator, just leave it blank. +# +############################################################################ +# +# Links: stripunb +# +############################################################################ + +link stripunb + +procedure readtbl(f) + + local t, line, k, on_sequence, off_sequence + + /f & stop("readtbl: Arg must be a valid open file.") + + t := table() + + every line := trim(!f,'\t ') do { + line ? { + k := tabslashupto('\t:') & + tab(many('\t:')) & + on_sequence := tabslashupto('\t:') | tab(0) + tab(many('\t:')) + off_sequence := tab(0) + } | stop("readtbl: Bad map file format.") + insert(t, k, outstr(on_sequence, off_sequence)) + } + + return t + +end + + + +procedure tabslashupto(c,s) + local POS + + POS := &pos + + while tab(upto('\\' ++ c)) do { + if ="\\" then { + move(1) + next + } + else { + if any(c) then { + suspend &subject[POS:.&pos] + } + } + } + + &pos := POS + fail + +end diff --git a/ipl/procs/reassign.icn b/ipl/procs/reassign.icn new file mode 100644 index 0000000..f47587d --- /dev/null +++ b/ipl/procs/reassign.icn @@ -0,0 +1,57 @@ +############################################################################# +# +# File: reassign.icn +# +# Subject: Procedures to access RE groupings and format into a string +# +# Author: David A. Gamey +# +# Date: May 2, 2001 +# +############################################################################# +# +# This file is in the public domain. +# +############################################################################# +# +# Descriptions: +# +# ReAssign( s ) : s2 +# +# Replaces sequences of \n in s with the corresponding parenthesis +# groups from the last regular expression match/find (if one exists). +# +# Special characters: +# \n use nth parenthesis group +# \\ escaped \ +# \n.i nth group followed by a number +# +# +############################################################################# +# +# Links: regexp +# +############################################################################ + +link regexp + +procedure ReAssign( s ) +local s1, n + +s1 := "" + +s ? +{ + while s1 := 1( tab(upto('\\')), move(1) ) do + { + if s1 ||:= ="\\" then next + if n := integer(tab(many(&digits))) then + { + n := Re_ParenGroups[n] + s1 ||:= n + if ( =".", tab(any(&digits)) ) then move(-1) + } + } + return s1 ||:= tab(0) +} +end diff --git a/ipl/procs/rec2tab.icn b/ipl/procs/rec2tab.icn new file mode 100644 index 0000000..e6ba1f7 --- /dev/null +++ b/ipl/procs/rec2tab.icn @@ -0,0 +1,36 @@ +############################################################################ +# +# File: rec2tab.icn +# +# Subject: Procedure to write record as string +# +# Author: Ralph E. Griswold +# +# Date: July 6, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure writes fields of a record as tab-separated string. +# Carriage returns in files are converted to vertical tabs. +# (Works for lists too.) +# +############################################################################ + +procedure rec2tab(rec, output) + local i, x + + i := *rec - 1 + every i := 1 to *rec - 1 do { + x := rec[i] + /x := "" + writes(output, map(x, "\n", "\v"),"\t") + } + write(output, map(\rec[-1], "\n", "\v")) | write(output) + + return + +end diff --git a/ipl/procs/recog.icn b/ipl/procs/recog.icn new file mode 100644 index 0000000..d13f32c --- /dev/null +++ b/ipl/procs/recog.icn @@ -0,0 +1,36 @@ +############################################################################ +# +# File: recog.icn +# +# Subject: Procedure for recognition +# +# Author: Ralph E. Griswold +# +# Date: May 29, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure serves as a main procedure for the output of +# recognizers. +# +############################################################################ +# +# See also: pargen.icn +# +############################################################################ + +procedure main() + local line + + init() + while line := read() do { + writes(image(line)) + if line ? (goal() & pos(0)) then + write(": accepted") + else write(": rejected") + } +end diff --git a/ipl/procs/records.icn b/ipl/procs/records.icn new file mode 100644 index 0000000..17056d8 --- /dev/null +++ b/ipl/procs/records.icn @@ -0,0 +1,56 @@ +############################################################################ +# +# File: records.icn +# +# Subject: Procedures to manipulate records +# +# Authors: Ralph E. Griswold and Gregg M. Townsend +# +# Date: November 4, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Contributor: Paul Abrahams +# +############################################################################ +# +# field(R, i) returns the name of the ith field of R. +# +# fieldnum(R, s) returns the index of the field named s in record R. +# +# movecorr(R1, R2) copies values from the fields of record R1 into +# fields of the same names (if any) in record R2, and returns R2. +# +############################################################################ + +procedure field(R, i) #: return name of field R[i] + + name(R[i]) ? { + tab(upto('.') + 1) + return tab(0) + } + +end + +procedure fieldnum(R, s) #: return index of field R.s + local i + + R := copy(R) + every i := 1 to *R do + R[i] := i + return R[s] +end + +procedure movecorr(R1, R2) #: move corresponding record fields + local s + static name + initial name := proc("name", 0) # protect attractive name + + every s := (name(!R1) ? (tab(upto('.') + 1) & tab(0))) do + R2[s] := R1[s] + return R2 +end diff --git a/ipl/procs/recrfncs.icn b/ipl/procs/recrfncs.icn new file mode 100644 index 0000000..80a0dbc --- /dev/null +++ b/ipl/procs/recrfncs.icn @@ -0,0 +1,73 @@ +############################################################################ +# +# File: recrfncs.icn +# +# Subject: Procedures for recursive functions +# +# Author: Ralph E. Griswold +# +# Date: December 5, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures implement commonly referenced ``text-book'' +# recursively defined functions. +# +# acker(i, j) Ackermann's function +# fib(i) Fibonacci sequence +# g(k, i) generalized Hofstader nested recurrence +# q(i) chaotic sequence +# +############################################################################ +# +# See also: fastfncs.icn, iterfncs.icn, and memrfncs.icn +# +############################################################################ +# +# Links: numbers +# +############################################################################ + +link numbers +procedure acker(i, j) + + if i = 0 then return j + 1 + if j = 0 then return acker(i - 1, 1) + else return acker(i - 1, acker(i, j - 1)) + +end + +procedure fib(i) + + if i = (1 | 2) then return 1 + + else return fib(i - 1) + fib(i - 2) + +end + +procedure g(k, n) + local value + static psi + + initial psi := 1.0 / &phi + + if n = 0 then return 0 + + value := 0 + + value +:= floor(psi * floor((seq(0) \ k + n) / real(k)) + psi) + + return value + +end + +procedure q(i) + + if i = (1 | 2) then return 1 + else return q(i - q(i - 1)) + q(i - q(i - 2)) + +end diff --git a/ipl/procs/recurmap.icn b/ipl/procs/recurmap.icn new file mode 100644 index 0000000..49823f7 --- /dev/null +++ b/ipl/procs/recurmap.icn @@ -0,0 +1,53 @@ +############################################################################ +# +# File: recurmap.icn +# +# Subject: Procedure to map recurrence declarations to procedures +# +# Author: Ralph E. Griswold +# +# Date: February 17, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure maps a recurrence declaration of the form +# +# f(i): +# if expr11 then expr12 +# if expr21 then expr22 +# ... +# else expr +# +# The declaration if passed to recurmap() in the form of a list. +# The result is returned as a string constituting an Icon procedure +# declaration. +# +# into an Icon procedure that compute corresponding values. +# +# At present there is no error checking and the most naive form of +# code is generated. +# +############################################################################ + +procedure recurmap(recur) + local line, proto, result + + result := "" + + every line := !recur do { + line ? { + if proto := tab(upto(":")) & pos(-1) then { + result ||:= "procedure " || proto || "\nreturn {\n" + } + else result ||:= || tab(0) || "\n" + } + } + + return result || "}\nend" + +end + diff --git a/ipl/procs/reduce.icn b/ipl/procs/reduce.icn new file mode 100644 index 0000000..861ef38 --- /dev/null +++ b/ipl/procs/reduce.icn @@ -0,0 +1,34 @@ +############################################################################ +# +# File: reduce.icn +# +# Subject: Procedure to perform operation on list of arguments +# +# Author: Ralph E. Griswold +# +# Date: January 14, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# reduce(op, init, args[]) applies the binary operation op to all the +# values in args, using init as the initial value. For example, +# +# reduce("+", 1, args[]) +# +# produces the sum of the values in args. +# +############################################################################ + +procedure reduce(op, init, args[]) + + op := proc(op, 2) | stop("*** invalid operator for reduce()") + + every init := op(init, !args) + + return init + +end diff --git a/ipl/procs/regexp.icn b/ipl/procs/regexp.icn new file mode 100644 index 0000000..6b881f5 --- /dev/null +++ b/ipl/procs/regexp.icn @@ -0,0 +1,831 @@ +############################################################################ +# +# File: regexp.icn +# +# Subject: Procedure for regular-expression pattern matching +# +# Author: Robert J. Alexander +# +# Date: May 19, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This is a kit of procedures to deal with UNIX-like regular expression +# patterns. +# +# These procedures are interesting partly because of the "recursive +# suspension" (or "suspensive recursion" :-) technique used to simulate +# conjunction of an arbitrary number of computed expressions (see +# notes, below). +# +# The public procedures are: +# +# ReMatch(pattern,s,i1,i2) : i3,i4,...,iN +# ReFind(pattern,s,i1,i2) : i3,i4,...,iN +# RePat(s) : pattern list +# +############################################################################ +# +# ReMatch() produces the sequence of positions in "s" past a substring +# starting at "i1" that matches "pattern", but fails if there is no +# such position. Similar to match(), but is capable of generating +# multiple positions. +# +# ReFind() produces the sequence of positions in "s" where substrings +# begin that match "pattern", but fails if there is no such position. +# Similar to find(). Each position is produced only once, even if +# several possible matches are possible at that position. +# +# "pattern" can be either a string or a pattern list -- see RePat(), +# below. +# +# Default values of s, i1, and i2 are handled as for Icon's built-in +# string scanning procedures such as match(). +# +############################################################################ +# +# RePat(s) : L +# +# Creates a pattern element list from pattern string "s", but fails if +# the pattern string is not syntactically correct. ReMatch() and +# ReFind() will automatically convert a pattern string to a pattern +# list, but it is faster to do the conversion explicitly if multiple +# operations are done using the same pattern. An additional advantage +# to compiling the pattern separately is avoiding ambiguity of failure +# caused by an incorrect pattern and failure to match a correct pattern. +# +############################################################################ +# +# ReCaseIndependent() : n +# ReCaseDependent() : n +# +# Set mode for case-independent or case-dependent matching. The initial +# mode is case-dependent. +# +############################################################################ +# +# Accessible Global Variables +# +# After a match, the strings matched by parenthesized regular +# expressions are left in list "Re_ParenGroups", and can be accessed by +# subscripting in using the same number as the \N construct. +# +# If it is desired that regular expression format be similar to UNIX +# filename generation patterns but still retain the power of full +# regular expressions, make the following assignments prior to +# compiling the pattern string: +# +# Re_ArbString := "*" # Defaults to ".*" +# +# The sets of characters (csets) that define a word, digits, and white +# space can be modified. The following assignments can be made before +# compiling the pattern string. The character sets are captured when +# the pattern is compiled, so changing them after pattern compilation +# will not alter the behavior of matches unless the pattern string is +# recompiled. +# +# Re_WordChars := 'whatever you like' +# # Defaults to &letters ++ &digits ++ "_" +# Re_Digits := &digits ++ 'ABCDEFabcdef' +# # Defaults to &digits +# Re_Space := 'whatever you like' +# # Defaults to ' \t\v\n\r\f' +# +# These globals are normally not initialized until the first call to +# RePat(), and then only if they are null. They can be explicitly +# initialized to their defaults (if they are null) by calling +# Re_Default(). +# +############################################################################ +# +# Characters compiled into patterns can be passed through a +# user-supplied filter procedure, provided in global variable +# Re_Filter. The filtering is done before the characters are bound +# into the pattern. The filter proc is passed one argument, the string +# to filter, and it must return the filtered string as its result. If +# the filter proc fails, the string will be used unfiltered. The +# filter proc is called with an argument of either type string (for +# characters in the pattern) or cset (for character classes [...]). +# +# Filtering is done only as the pattern is compiled. Any filtering of +# strings to be matched must be explicitly done. +# +############################################################################ +# +# By default, individual pattern elements are matched in a "leftmost- +# longest-first" sequence, which is the order observed by perl, egrep, +# and most other regular expression matchers. If the order of matching +# is not important a performance improvement might be seen if pattern +# elements are matched in "shortest-first" order. The following global +# variable setting causes the matcher to operate in leftmost-shortest- +# first order. +# +# Re_LeftmostShortest := 1 +# +############################################################################ +# +# In the case of patterns containing alternation, ReFind() will +# generally not produce positions in increasing order, but will produce +# all positions from the first term of the alternation (in increasing +# order) followed by all positions from the second (in increasing +# order). If it is necessary that the positions be generated in +# strictly increasing order, with no duplicates, assign any non-null +# value to Re_Ordered: +# +# Re_Ordered := 1 +# +# If the Re_Ordered option is chosen, there is a *small* penalty in +# efficiency in some cases, and the co-expression facility is required +# in your Icon implementation. +# +############################################################################ +# +# Regular Expression Characters and Features Supported +# +# The regular expression format supported by procedures in this file +# model very closely those supported by the UNIX "egrep" program, with +# modifications as described in the Perl programming language +# definition. Following is a brief description of the special +# characters used in regular expressions. In the description, the +# abbreviation RE means regular expression. +# +# c An ordinary character (not one of the special characters +# discussed below) is a one-character RE that matches that +# character. +# +# \c A backslash followed by any special character is a one- +# character RE that matches the special character itself. +# +# Note that backslash escape sequences representing +# non-graphic characters are not supported directly +# by these procedures. Of course, strings coded in an +# Icon program will have such escapes handled by the +# Icon translator. If such escapes must be supported +# in strings read from the run-time environment (e.g. +# files), they will have to be converted by other means, +# such as the Icon Program Library procedure "escape()". +# +# . A period is a one-character RE that matches any +# character. +# +# [string] A non-empty string enclosed in square brackets is a one- +# character RE that matches any *one* character of that +# string. If, the first character is "^" (circumflex), +# the RE matches any character not in the remaining +# characters of the string. The "-" (minus), when between +# two other characters, may be used to indicate a range of +# consecutive ASCII characters (e.g. [0-9] is equivalent to +# [0123456789]). Other special characters stand for +# themselves in a bracketed string. +# +# * Matches zero or more occurrences of the RE to its left. +# +# + Matches one or more occurrences of the RE to its left. +# +# ? Matches zero or one occurrences of the RE to its left. +# +# {N} Matches exactly N occurrences of the RE to its left. +# +# {N,} Matches at least N occurrences of the RE to its left. +# +# {N,M} Matches at least N occurrences but at most M occurrences +# of the RE to its left. +# +# ^ A caret at the beginning of an entire RE constrains +# that RE to match an initial substring of the subject +# string. +# +# $ A currency symbol at the end of an entire RE constrains +# that RE to match a final substring of the subject string. +# +# | Alternation: two REs separated by "|" match either a +# match for the first or a match for the second. +# +# () A RE enclosed in parentheses matches a match for the +# regular expression (parenthesized groups are used +# for grouping, and for accessing the matched string +# subsequently in the match using the \N expression). +# +# \N Where N is a digit in the range 1-9, matches the same +# string of characters as was matched by a parenthesized +# RE to the left in the same RE. The sub-expression +# specified is that beginning with the Nth occurrence +# of "(" counting from the left. E.g., ^(.*)\1$ matches +# a string consisting of two consecutive occurrences of +# the same string. +# +############################################################################ +# +# Extensions beyond UNIX egrep +# +# The following extensions to UNIX REs, as specified in the Perl +# programming language, are supported. +# +# \w Matches any alphanumeric (including "_"). +# \W Matches any non-alphanumeric. +# +# \b Matches only at a word-boundary (word defined as a string +# of alphanumerics as in \w). +# \B Matches only non-word-boundaries. +# +# \s Matches any white-space character. +# \S Matches any non-white-space character. +# +# \d Matches any digit [0-9]. +# \D Matches any non-digit. +# +# \w, \W, \s, \S, \d, \D can be used within [string] REs. +# +############################################################################ +# +# Notes on computed conjunction expressions by "suspensive recursion" +# +# A conjunction expression of an arbitrary number of terms can be +# computed in a looping fashion by the following recursive technique: +# +# procedure Conjunct(v) +# if <there is another term to be appended to the conjunction> then +# suspend Conjunct(<the next term expression>) +# else +# suspend v +# end +# +# The argument "v" is needed for producing the value of the last term +# as the value of the conjunction expression, accurately modeling Icon +# conjunction. If the value of the conjunction is not needed, the +# technique can be slightly simplified by eliminating "v": +# +# procedure ConjunctAndProduceNull() +# if <there is another term to be appended to the conjunction> then +# suspend ConjunctAndProduceNull(<the next term expression>) +# else +# suspend +# end +# +# Note that <the next term expression> must still remain in the suspend +# expression to test for failure of the term, although its value is not +# passed to the recursive invocation. This could have been coded as +# +# suspend <the next term expression> & ConjunctAndProduceNull() +# +# but wouldn't have been as provocative. +# +# Since the computed conjunctions in this program are evaluated only for +# their side effects, the second technique is used in two situations: +# +# (1) To compute the conjunction of all of the elements in the +# regular expression pattern list (Re_match1()). +# +# (2) To evaluate the "exactly N times" and "N to M times" +# control operations (Re_NTimes()). +# +############################################################################ + +record Re_Tok(proc,args) + +global Re_ParenGroups,Re_Filter,Re_Ordered +global Re_WordChars,Re_NonWordChars +global Re_Space,Re_NonSpace +global Re_Digits,Re_NonDigits +global Re_ArbString,Re_AnyString +global Re_LeftmostShortest + +invocable "=":1 + +################### Pattern Translation Procedures ################### + + +procedure RePat(s) #: regular expression pattern list +# +# Produce pattern list representing pattern string s. +# + # + # Create a list of pattern elements. Pattern strings are parsed + # and converted into list elements as shown in the following table. + # Since some list elements reference other pattern lists, the + # structure is really a tree. + # + # Token Generates Matches... + # ----- --------- ---------- + # ^ Re_Tok(pos,[1]) Start of string or line + # $ Re_Tok(pos,[0]) End of string or line + # . Re_Tok(move,[1]) Any single character + # + Re_Tok(Re_OneOrMore,[tok]) At least one occurrence of + # previous token + # * Re_Tok(Re_ArbNo,[tok]) Zero or more occurrences of + # previous token + # | Re_Tok(Re_Alt,[pattern,pattern]) Either of prior expression + # or next expression + # [...] Re_Tok(Re_TabAny,[cset]) Any single character in + # specified set (see below) + # (...) Re_Tok(Re_MatchReg,[pattern]) Parenthesized pattern as + # single token + # <string of non-special characters> The string of no-special + # Re_Tok(Re__tabmatch,string) characters + # \b Re_Tok(Re_WordBoundary,[Re_WordChars,Re_NonWordChars]) + # A word-boundary + # (word default: [A-Za-z0-9_]+) + # \B Re_Tok(Re_NonWordBoundary,[Re_WordChars,Re_NonWordChars]) + # A non-word-boundary + # \w Re_Tok(Re_TabAny,[Re_WordChars])A word-character + # \W Re_Tok(Re_TabAny,[Re_NonWordChars]) A non-word-character + # \s Re_Tok(Re_TabAny,[Re_Space]) A space-character + # \S Re_Tok(Re_TabAny,[Re_NonSpace]) A non-space-character + # \d Re_Tok(Re_TabAny,[Re_Digits]) A digit + # \D Re_Tok(Re_TabAny,[Re_NonDigits]) A non-digit + # {n,m} Re_Tok(Re_NToMTimes,[tok,n,m]) n to m occurrences of + # previous token + # {n,} Re_Tok(Re_NOrMoreTimes,[tok,n]) n or more occurrences of + # previous token + # {n} Re_Tok(Re_NTimes,[tok,n]) exactly n occurrences of + # previous token + # ? Re_Tok(Re_ZeroOrOneTimes,[tok]) one or zero occurrences of + # previous token + # \<digit> Re_Tok(Re_MatchParenGroup,[n]) The string matched by + # parenthesis group <digit> + # + local plist + static lastString,lastPList + # + # Initialize. + # + initial { + Re_Default() + lastString := "" + lastPList := [] + } + + if s === lastString then return lastPList + + Re_WordChars := cset(Re_WordChars) + Re_NonWordChars := ~Re_WordChars + Re_Space := cset(Re_Space) + Re_NonSpace := ~Re_Space + Re_Digits := cset(Re_Digits) + Re_NonDigits := ~Re_Digits + + + s ? (plist := Re_pat1(0)) | fail + lastString := s + lastPList := plist + return plist +end + + +procedure Re_pat1(level) # L +# +# Recursive portion of RePat() +# + local plist,n,m,c,comma + static parenNbr + initial { + if /Re__match then ReCaseDependent() + } + if level = 0 then parenNbr := 0 + plist := [] + # + # Loop to put pattern elements on list. + # + until pos(0) do { + (="|",plist := [Re_Tok(Re_Alt,[plist,Re_pat1(level + 1) | fail])]) | + put(plist, + (="^",pos(2) | &subject[-2] == ("|" | "("),Re_Tok(pos,[1])) | + (="$",pos(0) | match("|" | ")"),Re_Tok(pos,[0])) | + (match(")"),level > 0,break) | + (=Re_ArbString,Re_Tok(Re_Arb)) | + (=Re_AnyString,Re_Tok(move,[1])) | + (="+",Re_Tok(Re_OneOrMore,[Re_prevTok(plist) | fail])) | + (="*",Re_Tok(Re_ArbNo,[Re_prevTok(plist) | fail])) | + 1(Re_Tok(Re_TabAny,[c := Re_cset()]),\c | fail) | + 3(="(",n := parenNbr +:= 1, + Re_Tok(Re_MatchReg,[Re_pat1(level + 1) | fail,n]), + move(1) | fail) | + (="\\b",Re_Tok(Re_WordBoundary,[Re_WordChars,Re_NonWordChars])) | + (="\\B",Re_Tok(Re_NonWordBoundary,[Re_WordChars,Re_NonWordChars])) | + (="\\w",Re_Tok(Re_TabAny,[Re_WordChars])) | + (="\\W",Re_Tok(Re_TabAny,[Re_NonWordChars])) | + (="\\s",Re_Tok(Re_TabAny,[Re_Space])) | + (="\\S",Re_Tok(Re_TabAny,[Re_NonSpace])) | + (="\\d",Re_Tok(Re_TabAny,[Re_Digits])) | + (="\\D",Re_Tok(Re_TabAny,[Re_NonDigits])) | + (="{",(n := tab(many(&digits)),comma := =(",") | &null, + m := tab(many(&digits)) | &null,="}") | fail, + if \m then Re_Tok(Re_NToMTimes, + [Re_prevTok(plist),integer(n),integer(m)]) + else if \comma then Re_Tok(Re_NOrMoreTimes, + [Re_prevTok(plist),integer(n)]) + else Re_Tok(Re_NTimes,[Re_prevTok(plist),integer(n)])) | + (="?",Re_Tok(Re_ZeroOrOneTimes,[Re_prevTok(plist) | fail])) | + Re_Tok(Re__tabmatch,[Re_string(level)]) | + (="\\",n := tab(any(&digits)),Re_Tok(Re_MatchParenGroup,[integer(n)])) + ) | + fail + } + return plist +end + + +procedure Re_prevTok(plist) +# +# Pull previous token from the pattern list. This procedure must take +# into account the fact that successive character tokens have been +# optimized into a single string token. +# + local lastTok,s,r + lastTok := pull(plist) | fail + if lastTok.proc === Re__tabmatch then { + s := lastTok.args[1] + r := Re_Tok(Re__tabmatch,[s[-1]]) + s[-1] := "" + if *s > 0 then { + put(plist,lastTok) + lastTok.args[1] := s + } + return r + } + return lastTok +end + + +procedure Re_Default() +# +# Assign default values to regular expression translation globals, but +# only to variables whose values are null. +# + /Re_WordChars := &letters ++ &digits ++ "_" + /Re_Space := ' \t\v\n\r\f' + /Re_Digits := &digits + /Re_ArbString := ".*" + /Re_AnyString := "." + return +end + + +procedure Re_cset() +# +# Matches a [...] construct and returns a cset. +# + local complement,c,e,ch,chars + ="[" | fail + (complement := ="^" | &null,c := move(1) || tab(find("]")),move(1)) | + return &null + c ? { + e := (="-" | "") + while chars := tab(upto('-\\')) do { + e ++:= case move(1) of { + "-": chars[1:-1] ++ + &cset[ord(chars[-1]) + 1:ord(move(1)) + 2] | return &null + "\\": case ch := move(1) of { + "w": Re_WordChars + "W": Re_NonWordChars + "s": Re_Space + "S": Re_NonSpace + "d": Re_Digits + "D": Re_NonDigits + default: ch + } + } + } + e ++:= tab(0) + if \complement then e := ~e + } + e := (\Re_Filter)(e) + return cset(e) +end + + +procedure Re_string(level) +# +# Matches a string of non-special characters, returning a string. +# + local special,s,p + static nondigits + initial nondigits := ~&digits + special := if level = 0 then '\\.+*|[({?' else '\\.+*|[({?)' + s := tab(upto(special) | 0) + while ="\\" do { + p := &pos + if tab(any('wWbBsSdD')) | + (tab(any('123456789')) & (pos(0) | any(nondigits))) then { + tab(p - 1) + break + } + s ||:= move(1) || tab(upto(special) | 0) + } + if pos(0) & s[-1] == "$" then { + move(-1) + s[-1] := "" + } + s := string((\Re_Filter)(s)) + return "" ~== s +end + + +##################### Matching Engine Procedures ######################## + + +procedure ReMatch(plist,s,i1,i2) #: position past regular expression matched +# +# Produce the sequence of positions in s past a string starting at i1 +# that matches the pattern plist, but fails if there is no such +# position. Similar to match(), but is capable of generating multiple +# positions. +# + local i + if type(plist) ~== "list" then plist := RePat(plist) | fail + if /s := &subject then /i1 := &pos else /i1 := 1 ; /i2 := 0 + i := match("",s,i1,i2) - 1 | fail + Re_ParenGroups := [] + suspend s[i1:i2] ? (Re_match1(plist,1),i + &pos) +end + + +procedure Re_match1(plist,i) # s1,s2,...,sN +# +# Used privately by ReMatch() to simulate a computed conjunction +# expression via recursive generation. +# + local tok + suspend if tok := plist[i] then + Re_tok_match(tok,plist,i) & Re_match1(plist,i + 1) else &null +end + + +procedure ReFind(plist,s,i1,i2) #: position where regular expression matched +# +# Produce the sequence of positions in s where strings begin that match +# the pattern plist, but fails if there is no such position. Similar +# to find(). +# + local i,p + if type(plist) ~== "list" then plist := RePat(plist) | fail + if /s := &subject then /i1 := &pos else /i1 := 1 ; /i2 := 0 + i := match("",s,i1,i2) - 1 | fail + Re_ParenGroups := [] + s[i1:i2] ? suspend ( + tab(Re_skip(plist)) & + p := &pos & + Re_match1(plist,1)\1 & + i + p) +end + + +procedure Re_tok_match(tok,plist,i) +# +# Match a single token. Can be recursively called by the token +# procedure. +# + local prc,results,result + prc := tok.proc + if \Re_LeftmostShortest then + suspend if prc === Re_Arb then Re_Arb(plist,i) else prc!tok.args + else { + results := [] + every (if prc === Re_Arb then Re_Arb(plist,i) else prc!tok.args) do + push(results,[&pos,copy(Re_ParenGroups)]) + every result := !results do { + Re_ParenGroups := result[2] + suspend tab(result[1]) + } + } +end + + +########## Heuristic Code for Matching Arbitrary Characters ########## + + +procedure Re_skip(plist,i) # s1,s2,...,sN +# +# Used privately -- match a sequence of strings in s past which a match +# of the first pattern element in plist is likely to succeed. This +# procedure is used for heuristic performance improvement by ReMatch() +# for the ".*" pattern element, and by ReFind(). +# + local x,s,p,prc,args + /i := 1 + x := if type(plist) == "list" then plist[i] else plist + if /x then suspend find("") + else { + args := x.args + suspend case prc := x.proc of { + Re__tabmatch: Re__find!args + Re_TabAny: Re__upto!args + pos: args[1] + Re_WordBoundary | + Re_NonWordBoundary: + p := &pos & tab(Re_skip(plist,i + 1)) & prc!args & untab(p) + Re_MatchParenGroup: if s := \(\Re_ParenGroups)[args[1]] then + find(s) else find("") + Re_NToMTimes | + Re_NOrMoreTimes | + Re_NTimes: + if args[2] > 0 then Re_skip(args[1]) else find("") + Re_OneOrMore | + Re_MatchReg: Re_skip(args[1]) + Re_Alt: + if \Re_Ordered then + Re_result_merge{Re_skip(args[1]),Re_skip(args[2])} + else + Re_skip(args[1 | 2]) + default: find("") + } + } +end + + +procedure Re_result_merge(L) +# +# Programmer-defined control operation to merge the result sequences of +# two integer-producing generators. Both generators must produce their +# result sequences in numerically increasing order with no duplicates, +# and the output sequence will be in increasing order with no +# duplicates. +# + local e1,e2,r1,r2 + e1 := L[1] ; e2 := L[2] + r1 := @e1 ; r2 := @e2 + while \(r1 | r2) do + if /r2 | \r1 < r2 then + suspend r1 do r1 := @e1 | &null + else if /r1 | r1 > r2 then + suspend r2 do r2 := @e2 | &null + else + r2 := @e2 | &null +end + + +procedure untab(origPos) +# +# Converts a string scanning expression that moves the cursor to one +# that produces a cursor position and doesn't move the cursor (converts +# something like tab(find(x)) to find(x). The template for using this +# procedure is +# +# origPos := &pos ; tab(x) & ... & untab(origPos) +# + local newPos + newPos := &pos + tab(origPos) + suspend newPos + tab(newPos) +end + + +####################### Matching Procedures ####################### + + +procedure Re_Arb(plist,i) +# +# Match arbitrary characters (.*) +# + suspend tab(if plist[i + 1] then Re_skip(plist,i + 1) else Re__find("")) +end + + +procedure Re_TabAny(C) +# +# Match a character of a character set ([...],\w,\W,\s,\S,\d,\D) +# + suspend tab(Re__any(C)) +end + + +procedure Re_MatchReg(tokList,groupNbr) +# +# Match parenthesized group and assign matched string to list Re_ParenGroup +# + local p,s + p := &pos + /Re_ParenGroups := [] + every Re_match1(tokList,1) do { + while *Re_ParenGroups < groupNbr do put(Re_ParenGroups) + s := &subject[p:&pos] + Re_ParenGroups[groupNbr] := s + suspend s + } + Re_ParenGroups[groupNbr] := &null +end + + +procedure Re_WordBoundary(wd,nonwd) +# +# Match word-boundary (\b) +# + suspend ((pos(1),any(wd)) | (pos(0),move(-1),tab(any(wd))) | (move(-1), + (tab(any(wd)),any(nonwd)) | (tab(any(nonwd)),any(wd))),"") +end + + +procedure Re_NonWordBoundary(wd,nonwd) +# +# Match non-word-boundary (\B) +# + suspend ((pos(1),any(nonwd)) | (pos(0),move(-1),tab(any(nonwd))) | (move(-1), + (tab(any(wd)),any(wd)) | (tab(any(nonwd)),any(nonwd)),"")) +end + + +procedure Re_MatchParenGroup(n) +# +# Match same string matched by previous parenthesized group (\N) +# + local s + suspend if s := \Re_ParenGroups[n] then =s else "" +end + + +################### Control Operation Procedures ################### + + +procedure Re_ArbNo(tok) +# +# Match any number of times (*) +# + suspend "" | (Re_tok_match(tok) & Re_ArbNo(tok)) +end + + +procedure Re_OneOrMore(tok) +# +# Match one or more times (+) +# + suspend Re_tok_match(tok) & Re_ArbNo(tok) +end + + +procedure Re_NToMTimes(tok,n,m) +# +# Match n to m times ({n,m} +# + suspend Re_NTimes(tok,n) & Re_ArbNo(tok)\(m - n + 1) +end + + +procedure Re_NOrMoreTimes(tok,n) +# +# Match n or more times ({n,}) +# + suspend Re_NTimes(tok,n) & Re_ArbNo(tok) +end + + +procedure Re_NTimes(tok,n) +# +# Match exactly n times ({n}) +# + if n > 0 then + suspend Re_tok_match(tok) & Re_NTimes(tok,n - 1) + else suspend +end + + +procedure Re_ZeroOrOneTimes(tok) +# +# Match zero or one times (?) +# + suspend "" | Re_tok_match(tok) +end + + +procedure Re_Alt(tokList1,tokList2) +# +# Alternation (|) +# + suspend Re_match1(tokList1 | tokList2,1) +end + + +################### Case Independence Procedures ################### + + +link noncase + +global Re__find,Re__match,Re__any,Re__many,Re__upto,Re__tabmatch + +procedure ReCaseIndependent() + Re__find := c_find + Re__match := c_match + Re__any := c_any + Re__many := c_many + Re__upto := c_upto + Re__tabmatch := Re_c_tabmatch + return +end + +procedure ReCaseDependent() + Re__find := find + Re__match := match + Re__any := any + Re__many := many + Re__upto := upto + Re__tabmatch := proc("=",1) + return +end + +procedure Re_c_tabmatch(s) + suspend tab(c_match(s)) +end diff --git a/ipl/procs/repetit.icn b/ipl/procs/repetit.icn new file mode 100644 index 0000000..d7dff78 --- /dev/null +++ b/ipl/procs/repetit.icn @@ -0,0 +1,60 @@ +############################################################################ +# +# File: repetit.icn +# +# Subject: Procedure to find smallest repetition pattern in list +# +# Author: Ralph E. Griswold +# +# Date: February 25, 2003 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure returns the length of the smallest range of values +# that repeat in a list. For example, if +# +# L := [1, 2, 3, 1, 2, 3, 1, 2, 3] +# +# repetit(L) returns 3. If there is no repetition, repetit() returns +# the length of the list. +# +############################################################################ + +procedure repetit(L) + local c, n, l, e, i + + c := L[1] # starting value + l := *L # end of list + + n := 2 # initial hypothesis + + n := \{ # tricky coding -- nonnull on success + until n >= l do + if hypothesis(L, n) then break n else { + n := \{ # more tricky coding + every i := n + 1 to l do + if L[i] === c then break i + } | return l # no repetition; whole thing - 1 + } | return l + } + + return n - 1 + +end + +procedure hypothesis(L, n) + local s, i, j + + s := *L / n + + every j := 1 to s do + every i := 1 to n do + if L[i] ~=== L[i + (n - 1) * j] then fail + + return + +end diff --git a/ipl/procs/revadd.icn b/ipl/procs/revadd.icn new file mode 100644 index 0000000..0c73315 --- /dev/null +++ b/ipl/procs/revadd.icn @@ -0,0 +1,49 @@ +############################################################################ +# +# File: revadd.icn +# +# Subject: Procedure to generate reverse-summed integers +# +# Author: Ralph E. Griswold +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure is designed to help explore the number-theory problem +# in which an integer is added to its (digit) reversal until a +# palindrome appears. +# +# It is unknown if this process terminates for all integers. For +# example, for 196, it appears not to, but no proof, to our +# knowledge, exists for nontermination. The radix used is important. +# For bases that are powers of 2, it can be proved that there are +# integers for which the process does not terminate in a palindrome. +# +############################################################################ +# +# Requires: Large integer arithmetic +# +############################################################################ + +# Generate integers in the reverse-addition sequence starting at i, +# but terminating when the number is palindromic. +# +# Note that revadd() returns an integer (native or large). + +procedure revadd(i) + local j + + i := integer(i) | stop("*** invalid type to revadd()") + + repeat { + j := reverse(i) + if i == j then return i else suspend i + i +:= j + } + +end diff --git a/ipl/procs/rewrap.icn b/ipl/procs/rewrap.icn new file mode 100644 index 0000000..21d8f80 --- /dev/null +++ b/ipl/procs/rewrap.icn @@ -0,0 +1,154 @@ +############################################################################ +# +# File: rewrap.icn +# +# Subject: Procedures for advanced line rewrap +# +# Author: Richard L. Goerwitz +# +# Date: March 3, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.4 +# +############################################################################ +# +# The procedure rewrap(s,i), included in this file, reformats text +# fed to it into strings < i in length. Rewrap utilizes a static +# buffer, so it can be called repeatedly with different s arguments, +# and still produce homogenous output. This buffer is flushed by +# calling rewrap with a null first argument. The default for +# argument 2 (i) is 70. +# +############################################################################ +# +# Here's a simple example of how rewrap could be used. The following +# program reads the standard input, producing fully rewrapped output. +# +# procedure main() +# every write(rewrap(!&input)) +# write(rewrap()) +# end +# +# Naturally, in practice you would want to do things like check for in- +# dentation or blank lines in order to wrap only on a paragraph-by para- +# graph basis, as in +# +# procedure main() +# while line := read(&input) do { +# if line == "" then { +# write("" ~== rewrap()) +# write(line) +# } else { +# if match("\t", line) then { +# write(rewrap()) +# write(rewrap(line)) +# } else { +# write(rewrap(line)) +# } +# } +# } +# end +# +# Fill-prefixes can be implemented simply by prepending them to the +# output of rewrap: +# +# i := 70; fill_prefix := " > " +# while line := read(input_file) do { +# line ?:= (f_bit := tab(many('> ')) | "", tab(0)) +# write(fill_prefix || f_bit || rewrap(line, i - *fill_prefix)) +# etc. +# +# Obviously, these examples are fairly simplistic. Putting them to +# actual use would certainly require a few environment-specific +# modifications and/or extensions. Still, I hope they offer some +# indication of the kinds of applications rewrap might be used in. +# +# Note: If you want leading and trailing tabs removed, map them to +# spaces first. Rewrap only fools with spaces, leaving tabs intact. +# This can be changed easily enough, by running its input through the +# Icon detab() function. +# +############################################################################ +# +# See also: wrap.icn +# +############################################################################ + + +procedure rewrap(s,i) + + local extra_bit, line + static old_line + initial old_line := "" + + # Default column to wrap on is 70. + /i := 70 + # Flush buffer on null first argument. + if /s then { + extra_bit := old_line + old_line := "" + return "" ~== extra_bit + } + + # Prepend to s anything that is in the buffer (leftovers from the last s). + s ?:= { tab(many(' ')); old_line || trim(tab(0)) } + + # If the line isn't long enough, just add everything to old_line. + if *s < i then old_line := s || " " & fail + + s ? { + + # While it is possible to find places to break s, do so. + while any(' -',line := EndToFront(i),-1) do { + # Clean up and suspend the last piece of s tabbed over. + line ?:= (tab(many(' ')), trim(tab(0))) + if *&subject - &pos + *line > i + then suspend line + else { + old_line := "" + return line || tab(0) + } + } + + # Keep the extra section of s in a buffer. + old_line := tab(0) + + # If the reason the remaining section of s was unrewrapable was + # that it was too long, and couldn't be broken up, then just return + # the thing as-is. + if *old_line > i then { + old_line ? { + if extra_bit := tab(upto(' -')+1) || (tab(many(' ')) | "") + then old_line := tab(0) + else extra_bit := old_line & old_line := "" + return trim(extra_bit) + } + } + # Otherwise, clean up the buffer for prepending to the next s. + else { + # If old_line is blank, then don't mess with it. Otherwise, + # add whatever is needed in order to link it with the next s. + if old_line ~== "" then { + # If old_line ends in a dash, then there's no need to add a + # space to it. + if old_line[-1] ~== "-" + then old_line ||:= " " + } + } + } + +end + + + +procedure EndToFront(i) + # Goes with rewrap(s,i) + *&subject+1 - &pos >= i | fail + suspend &subject[.&pos:&pos <- &pos+i to &pos by -1] +end diff --git a/ipl/procs/rng.icn b/ipl/procs/rng.icn new file mode 100644 index 0000000..8e945c4 --- /dev/null +++ b/ipl/procs/rng.icn @@ -0,0 +1,42 @@ +############################################################################ +# +# File: rng.icn +# +# Subject: Procedure to generate random numbers +# +# Author: Ralph E. Griswold +# +# Date: June 11, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure generates a sequence of numbers using the linear +# congruence method. With appropriate parameters, the result is +# a pseudo-random sequence. The default values produce the sequence +# used in Icon. +# +############################################################################ +# +# Requires: large integers +# +############################################################################ +# +# See also: lcseval.icn +# +############################################################################ + +procedure rng(a, c, m, x) + + /a := 1103515245 # multiplicative constant + /c := 453816694 # additive constant + /m := 2 ^ 31 - 1 # modulus + /x := 0 # initial value + + suspend x + suspend x := iand(a * |x + c, m) + +end diff --git a/ipl/procs/sandgen.icn b/ipl/procs/sandgen.icn new file mode 100644 index 0000000..aac4917 --- /dev/null +++ b/ipl/procs/sandgen.icn @@ -0,0 +1,494 @@ +############################################################################ +# +# File: sandgen.icn +# +# Subject: Procedures for "evaluation sandwiches" code +# +# Author: Ralph E. Griswold +# +# Date: November 19, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program is designed to be linked with the output of the meta- +# translator. These procedures produce "evaluation sandwiches" +# so that program execution can be monitored. +# +# See "Evaluation Sandwiches", Icon Analyst 6, pp. 8-10, 1991. +# +############################################################################ +# +# Bug: The invocable declaration is not handled properly. "invocable all" +# will get by, but some other forms produce syntax errors. The +# problem is in the meta-translator itself, not in this program. +# +############################################################################ +# +# Links: strings +# +############################################################################ + +link strings + +global code_gen + +procedure main() + + code_gen := sandwich # so it can be changed easily + + write("link prepost") # link the sandwich slices + + Mp() # call meta-procedure + +end + +procedure Alt(e1, e2) # e1 | e2 + + return code_gen("(", e1, "|", e2, ")") + +end + +procedure Apply(e1, e2) # e1 ! e2 + + return code_gen("(", e1, "!", e2, ")") + +end + +procedure Arg(e) + + return e + +end + +procedure Asgnop(op, e1, e2) # e1 op e2 + + return code_gen("(", e1, " ", op, " ", e2, ")") + +end + +procedure Augscan(e1, e2) # e1 ?:= e2 + + return code_gen("(", e1, " ?:= ", e2, ")") + +end + +procedure Bamper(e1, e2) # e1 & e2 + + return code_gen("(", e1, " & ", e2, ")") + +end + +procedure Binop(op, e1, e2) # e1 op e2 + + return code_gen("(", e1, " ", op, " ", e2, ")") + +end + +procedure Body(es[]) # procedure body + + every write(!es) + + return + +end + +procedure Break(e) # break e + + return code_gen("break ", e) + +end + +procedure Case(e, clist) # case e of { caselist } + + return code_gen("case ", e, " of {", clist, "}") + +end + +procedure Cclause(e1, e2) # e1 : e2 + + return code_gen(e1, " : ", e2, "\n") + +end + +procedure Clist(cclause1, cclause2) # cclause1 ; cclause2 + + return code_gen(cclause1, ";", cclause2) + +end + +procedure Clit(c) # 'c' + + return image(c) + +end + +procedure Compound(es[]) # { e1; e2; ... } + local result + + if *es = 0 then return "{}\n" + + result := "{\n" + every result ||:= !es || "\n" + + return code_gen(result, "}\n") + +end + +procedure Create(e) # create e + + return code_gen("create ", e) + +end + +procedure Default(e) # default: e + + return code_gen("default: ", e) + +end + +procedure End() # end + + write("end") + + return + +end + +procedure Every(e) # every e + + return code_gen("every ", e) + +end + +procedure EveryDo(e1, e2) # every e1 do e2 + + return code_gen("every ", e1, " do ", e2) + +end + +procedure Fail() # fail + + return "fail" + +end + +procedure Field(e, f) # e . f + + return code_gen("(", e, ".", f, ")") + +end + +procedure Global(vs[]) # global v1, v2, ... + local result + + result := "" + every result ||:= !vs || ", " + + write("global ", result[1:-2]) + + return + +end + +procedure If(e1, e2) # if e1 then e2 + + return code_gen("if ", e1, " then ", e2) + +end + +procedure IfElse(e1, e2, e3) # if e1 then e2 else e3 + + return code_gen("if ", e1, " then ", e2, " else ", e3) + +end + +procedure Ilit(i) # i + + return i + +end + +procedure Initial(e) # initial e + + write("initial ", e) + + return + +end + +procedure Invocable(ss[]) # invocable s1, s2, ... (problem) + + if \ss then write("invocable all") + else write("invocable ", ss) + + return + +end + +procedure Invoke(e, es[]) # e(e1, e2, ...) + local result + + if *es = 0 then return code_gen(e, "()") + + result := "" + every result ||:= !es || ", " + + return code_gen(e, "(", result[1:-2], ")") + +end + +procedure Key(s) # &s + + return code_gen("&", s) + +end + +procedure Limit(e1, e2) # e1 \ e2 + + return code_gen("(", e1, "\\", e2, ")") + +end + +procedure Link(vs[]) # link "v1, v2, ..." + local result + + result := "" + every result ||:= !vs || ", " + + write("link ", result[1:-2]) + + return + +end + +procedure List(es[]) # [e1, e2, ... ] + local result + + if *es = 0 then return "[]" + + result := "" + every result ||:= !es || ", " + + return code_gen("[", result[1:-2], "]") + +end + +procedure Local(vs[]) # local v1, v2, ... + local result + + result := "" + every result ||:= !vs || ", " + + write("local ", result[1:-2]) + + return + +end + +procedure Next() # next + + return "next" + +end + +procedure Not(e) # not e + + return code_gen("not(", e, ")") + +end + +procedure Null() # &null + + return "" + +end + +procedure Paren(es[]) # (e1, e2, ... ) + local result + + if *es = 0 then return "()" + + result := "" + every result ||:= !es || ", " + + return code_gen("(", result[1:-2], ")") + +end + +procedure Pdco(e, es[]) # e{e1, e2, ... } + local result + + if *es = 0 then return code_gen(e, "{}") + + result := "" + every result ||:= !es || ", " + + return code_gen(e, "{", result[1:-2], "}") + +end + +procedure Proc(n, vs[]) # procedure n(v1, v2, ...) + local result, v + + if *vs = 0 then write("procedure ", n, "()") + + result := "" + every v := !vs do + if \v == "[]" then result[-2:0] := v || ", " + else result ||:= (\v | "") || ", " + + write("procedure ", n, "(", result[1:-2], ")") + + return + +end + +procedure Record(n, fs[]) # record n(f1, f2, ...) + local result, field + + if *fs = 0 then write("record ", n, "()") + + result := "" + every field := !fs do + result ||:= (\field | "") || ", " + + write("record ", n, "(", result[1:-2], ")") + + return + +end + +procedure Repeat(e) # repeat e + + return code_gen("repeat ", e) + +end + +procedure Return(e) # return e + + return code_gen("return ", e) + +end + +procedure Rlit(r) # r + + return r + +end + +procedure Scan(e1, e2) # e1 ? e2 + + return code_gen("(", e1 , " ? ", e2, ")") + +end + +procedure Section(op, e1, e2, e3) # e1[e2 op e3] + + return code_gen(e1, "[", e2, op, e3, "]") + +end + +procedure Slit(s) # "s" + + return image(s) + +end + +procedure Static(vs[]) # static v1, v2, .. + local result + + result := "" + every result ||:= !vs || ", " + + write("static ", result[1:-2]) + + return + +end + +procedure Subscript(e1, e2) # e1[e2] + + return code_gen(e1, "[", e2, "]") + +end + +procedure Suspend(e) # suspend e + + return code_gen("suspend ", e) + +end + +procedure SuspendDo(e1, e2) # suspend e1 do e2 + + return code_gen("suspend ", e1, " do ", e2) + +end + +procedure To(e1, e2) # e1 to e2 + + return code_gen("(", e1, " to ", e2, ")") + +end + +procedure ToBy(e1, e2, e3) # e1 to e2 by e3 + + return code_gen("(", e1, " to ", e2, " by ", e3, ")") + +end + +procedure Repalt(e) # |e + + return code_gen("(|", e, ")") + +end + +procedure Unop(op, e) # op e + + return code_gen("(", op, e, ")") + +end + +procedure Until(e) # until e + + return code_gen("until ", e) + +end + +procedure UntilDo(e1, e2) # until e1 do e2 + + return code_gen("until ", e1, " do ", e2) + +end + +procedure Var(v) # v + + return v + +end + +procedure While(e) # while e + + return code_gen("while ", e) + +end + +procedure WhileDo(e1, e2) # while e1 do e2 + + return code_gen("while ", e1, " do ", e2) + +end + +# Generate "evaluation sandwich" code. + +procedure sandwich(s[]) + + push(s, "(pre(), post(") + put(s, "))") + + return cat ! s + +end diff --git a/ipl/procs/scan.icn b/ipl/procs/scan.icn new file mode 100644 index 0000000..2b8b5c6 --- /dev/null +++ b/ipl/procs/scan.icn @@ -0,0 +1,508 @@ +############################################################################ +# +# File: scan.icn +# +# Subject: Procedures related to scanning +# +# Author: Richard L. Goerwitz, David A. Gamey, and Ralph E. Griswold +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Contributors: Randal L. Schwartz and Cheyenne Wills +# +############################################################################ +# +# This module contains procedures related to string scanning: +# +# balq(c1, c2, c3, c4, c5, s, i1, i2) +# like bal() with quoting from characters in c5. +# +# balqc(c1, c2, c3, c4, c5, s1, s2, s3, i1, i2) +# like balq() with the addition that balanced characters within +# "comments", as delimited by the strings s1 and s2, are also +# excluded from balancing. In addition, if s1 is given and s2 +# +# limatch(L, c) +# matches items in list L delimited by characters in c +# +# slashbal(c1, c2, c3, s, i, j) +# like bal() with escape processing +# +# slashupto(c, s, i, j) +# like upto() with escape processing +# +# slshupto() +# synonym for slashupto() +# +# snapshot(title, len) +# snapshot of string scanning with optional title and +# maximum length. +# +# More extensive documentation proceeds each procedure. +# +############################################################################ +# +# Richard L. Goerwitz: +# +# I am often frustrated at bal()'s inability to deal elegantly with +# the common \backslash escaping convention (a way of telling Unix +# Bourne and C shells, for instance, not to interpret a given +# character as a "metacharacter"). I recognize that bal()'s generic +# behavior is a must, and so I wrote slashbal() to fill the gap. +# +# Slashbal behaves like bal, except that it ignores, for purposes of +# balancing, any c2/c3 char which is preceded by a backslash. Note +# that we are talking about internally represented backslashes, and +# not necessarily the backslashes used in Icon string literals. If +# you have "\(" in your source code, the string produced will have no +# backslash. To get this effect, you would need to write "\\(." +# +# BUGS: Note that, like bal() (v8), slashbal() cannot correctly +# handle cases where c2 and c3 intersect. Note also that older ver- +# sions of this routine counted from the beginning of the string, +# instead of from i. This feature came to be regarded as a bug when +# put into actual use (especially when I realized that bal() doesn't +# work this way). +# +############################################################################ + +procedure slashbal(c1, c2, c3, s, i, j) #: bal() with escapes + + local twocs, allcs, default_val, POS, chr, chr2, count + + /c1 := &cset + /c2 := '(' + /c3 := ')' + twocs := c2 ++ c3 + allcs := c1 ++ c2 ++ c3 ++ '\\' + + if /s := &subject + then default_val := &pos + else default_val := 1 + + if \i then { + if i < 1 then + i := *s + (i+1) + } + else i := default_val + if \j then { + if j < 1 then + j := *s + (j+1) + } + else j := *s + 1 + + count := 0; POS := i - 1 + s[i:j] ? { + while tab(upto(allcs)) do { + chr := move(1) + if chr == "\\" & any(twocs) then { + chr2 := move(1) + if any(c1, chr) & count = 0 then + suspend POS + .&pos - 2 + if any(c1, chr2) & count = 0 then + suspend POS + .&pos - 1 + } + else { + if any(c1, chr) & count = 0 then + suspend POS + .&pos - 1 + if any(c2, chr) then + count +:= 1 + else if any(c3, chr) & count > 0 then + count -:= 1 + } + } + } + +end + +############################################################################ +# +# Richard L. Goerwitz: +# +# Slshupto works just like upto, except that it ignores backslash +# escaped characters. I can't even begin to express how often I've +# run into problems applying Icon's string scanning facilities to +# to input that uses backslash escaping. Normally, I tokenize first, +# and then work with lists. With slshupto() I can now postpone or +# even eliminate the traditional tokenizing step, and let Icon's +# string scanning facilities to more of the work. +# +# If you're confused: +# +# Typically UNIX utilities (and probably others) use backslashes to +# "escape" (i.e. remove the special meaning of) metacharacters. For +# instance, UNIX shells normally accept "*" as a shorthand for "any +# series of zero or more characters. You can make the "*" a literal +# "*," with no special meaning, by prepending a backslash. The rou- +# tine slshupto() understands these backslashing conventions. You +# can use it to find the "*" and other special characters because it +# will ignore "escaped" characters. +# +############################################################################ + +# for compatibility with the original name +# +procedure slashupto(c, s, i, j) #: upto() with escapes + suspend slshupto(c, s, i, j) +end + +# +# slshupto: cset x string x integer x integer -> integers +# (c, s, i, j) -> Is (a generator) +# where Is are the integer positions in s[i:j] before characters +# in c that is not preceded by a backslash escape +# +procedure slshupto(c, s, i, j) #: upto() with escapes + + local c2 + + if /s := &subject + then /i := &pos + else /i := 1 + /j := *s + 1 + + /c := &cset + c2 := '\\' ++ c + s[1:j] ? { + tab(i) + while tab(upto(c2)) do { + if ="\\" then { + move(1) | { + if find("\\", c) + then return &pos - 1 + } + next + } + suspend .&pos + move(1) + } + } + +end + +############################################################################ +# +# The procedure snapshot(title,len) writes a snapshot of the state +# of string scanning, showing the value of &subject and &pos, an +# optional title, and (again optionally) wrapping the display +# for len widht. +# +# For example, +# +# "((a+b)-delta)/(c*d))" ? { +# tab(bal('+-/*')) +# snapshot("example") +# } +# +# produces +# +# ---example--------------------------- +# | | +# | | +# | &subject = "((a+b)-delta)/(c*d))" | +# | | | +# | | +# ------------------------------------- +# +# Note that the bar showing the &pos is positioned under the &posth +# character (actual positions are between characters). If &pos is +# at the end of &subject, the bar is positioned under the quotation +# mark delimiting the subject. For example, +# +# "abcdefgh" ? (tab(0) & snapshot()) +# +# produces +# +# ------------------------- +# | | +# | | +# | &subject = "abcdefgh" | +# | | | +# | | +# ------------------------- +# +# Escape sequences are handled properly. For example, +# +# "abc\tdef\nghi" ? (tab(upto('\n')) & snapshot()) +# +# produces +# +# ------------------------------ +# | | +# | | +# | &subject = "abc\tdef\nghi" | +# | | | +# | | +# ------------------------------ +# +# The title argument places a title into the top bar, as in +# +# "abc\tdef\nghi" ? (tab(upto('\n')) & snapshot("upto('\n')") +# +# which produces +# +# --upto('\n')------------------- +# | | +# | | +# | &subject = "abc\tdef\nghi" | +# | | | +# | | +# ------------------------------- +# +# The len argument rewraps the display for a screen of len width. +# +############################################################################ + + +procedure snapshot(title,len) #: snapshot of string scanning + + local bar1, bar2, bar3, is, is0, prefix, titlel, placement, POS + + /title := "" # no meaningful default + \len <:= 20 # any less is really not useful + prefix := "&subject = " + is := image(&subject) + is0 := *image(&subject[1:&pos]) | fail + + # + # Set up top and bottom bars (not exceeding len width, if + # len is nonnull). Fit title into top bar (bar1). + # + bar1 := bar3 := repl("-", *is + *prefix + 4)[1:\len-4|0] + # in *is + *prefix + 4, the 4 is for two vbars/two spaces + titlel := (*title > *bar3-4) | *title[1:\len-4|0] + bar1 ?:= move(3) || (tab(4+titlel), title) || tab(0) + + # + # Write bar1, then spacers (bar2). Then write out len-size chunks + # of &subject, with the | pointer-line, where appropriate. Finally, + # write out bar3 (like bar1, but with no title). + # + write(bar1) + bar2 := "|" || repl(" ", *bar3 - 2) || "|" + write(bar2, "\n", bar2) + placement := *prefix + is0 + (prefix || is) ? { + until pos(0) do { + POS := &pos - 1 + write("| ", move(*bar3-4) | left(tab(0), *bar3-4), " |") + if POS < placement < &pos then { + writes("| ") + writes(left(repl(" ", placement - POS - 1) || "|", *bar3-4)) + write(" |\n", bar2) + } + else write(bar2, "\n", bar2) + } + } + write(bar3) + return # nothing useful to return + +end + +############################################################################ +# +# David A. Gamey: +# +# balq( c1, c2, c3, c4, c5, s, i1, i2 ) : i3 +# +# generates the sequence of integer positions in s preceding a +# character of c1 in s[i1:i2] that is (a) balanced with respect to +# characters in c2 and c3 and (b) not "quoted" by characters in c4 +# with "escape" sequences as defined in c5, but +# fails if there is no such position. +# +# defaults: same as for bal, +# c4 the single and double quote characters ' and " +# c5 the backwards slash \ +# errors: same as for bal, +# c4 & c5 not csets +# +# balqc( c1, c2, c3, c4, c5, s1, s2, s3, i1, i2 ) : i3 +# +# like balq with the addition that balanced characters within +# "comments", as delimited by the strings s1 and s2, are also +# excluded from balancing. In addition, if s1 is given and s2 +# is null then the comment terminates at the end of string. +# +# defaults: same as for balq, +# s3 is the subject string +# s1 "/*" +# s2 "*/" if s1 defaults, null otherwise +# errors: same as for balq, +# s1 is not a string +# s2 is not a string (if s1 defaults or is specified) +# +############################################################################# + +procedure balq( #: bal() with quote escaping. + cstop, copen, cclose, cquote, cescape, s, i1, i2) + +local quote, pcount, spos +local ca, c, sp + +if /s := &subject then /i1 := &pos +/i1 := 1 +/i2 := 0 +/cstop := &cset # stopping characters +/copen := '(' # open characters +/cclose := ')' # close characters +/cquote := '\'\"' # quote characters +/cescape := '\\' # escape characters + + +pcount := 0 # "parenthesis" counter +spos := i1 # scanning position + +ca := cstop ++ copen ++ cclose ++ cquote ++ cescape # characters to check + +while sp := s[ spos := upto( ca, s, spos, i2 ) ] do { + + if /quote & ( pcount = 0 ) & any( cstop, sp) then suspend spos + + if any( c := ( copen | cclose | cquote | cescape ), sp ) then + + case c of { + + copen : if /quote then + pcount +:= 1 + + cclose : if /quote then + if ( pcount -:= 1 ) < 0 then + fail + + cquote : if /quote then + quote := sp + else + if quote == sp then quote := &null + + cescape: if \quote then + spos +:= 1 + } + + spos +:= 1 + + } + +end + +procedure balqc( #: balq() with comment escaping + cstop, copen, cclose, cquote, cescape, scm, ecm, s, i1, i2) + +local quote, pcount, spos +local ca, c, sp +local ccom, comnt + +if /s := &subject then /i1 := &pos +/i1 := 1 +/i2 := 0 +/cstop := &cset # stopping characters +/copen := '(' # open characters +/cclose := ')' # close characters +/cquote := '\'\"' # quote characters +/cescape := '\\' # escape characters + +if /scm & /ecm then { + scm := "/*" # start of comment + ecm := "*/" # end of comment + } +else + if \scm & /ecm then + ecm := &null # icon style comment + +ccom := '' +ccom ++:= cset(\scm[1]) +ccom ++:= cset(\ecm[1]) + +pcount := 0 # "parenthesis" counter +spos := i1 # scanning position + +ca := cstop ++ copen ++ cclose ++ cquote ++ cescape ++ ccom # chars to check + +while sp := s[ spos := upto( ca, s, spos, i2 ) ] do { + + if /quote & ( pcount = 0 ) & /comnt & any( cstop, sp) then + suspend spos + + if any( c := ( copen | cclose | cquote | cescape | ccom ), sp ) then + + case c of { + + copen : if /quote & /comnt then + pcount +:= 1 + + cclose : if /quote & /comnt then + if ( pcount -:= 1 ) < 0 then + fail + + cquote : if /comnt then + if /quote then + quote := sp + else + if quote == sp then quote := &null + + cescape: if \quote then + spos +:= 1 + + ccom : if /quote then + if /comnt then { + if comnt := ( s[ spos +: *scm ] == scm ) then + spos +:= *scm - 1 + } + else + if \ecm == s[ spos +: *ecm ] then { + spos +:= *ecm - 1 + comnt := &null + } + + } + + spos +:= 1 + + } + +end + +############################################################################# +# +# This matching function illustrates how every can be +# used in string scanning. +# +# 1. Each element of the list argument is matched in +# succession. +# 2. Leading characters in the subject are skipped over +# to match the first element. +# 3. The strings listed may be seperated by other characters +# provided they are specified in a cset of characters to +# be ignored. +# +# It could be used to find things in text that have varying +# representations, for example: "i.e.", "e.g.", "P.O.", etc. +# +# limatch(l,i) +# +# l list of strings to be found +# i cset containing characters to be ignored between each string +# +# returns the last cursor position scanned to, or fails +# +############################################################################# + +procedure limatch(l,i) #: matching items in list + +local s, f, p + +p := &pos +every ( s := !l ) | ( return p ) do +{ + if /f := 1 then tab(find(s)) # startup - position at first string + tab(match(s)) | fail # fail if not matched + tab(many(i) | &pos) # skip ignore chars. if any + p := &pos # remember last position +} +end diff --git a/ipl/procs/scanmodl.icn b/ipl/procs/scanmodl.icn new file mode 100644 index 0000000..540139e --- /dev/null +++ b/ipl/procs/scanmodl.icn @@ -0,0 +1,49 @@ +############################################################################ +# +# File: scanmodl.icn +# +# Subject: Procedures to model string scanning +# +# Author: Ralph E. Griswold +# +# Date: May 30, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures model string scanning: +# +# e1 ? e2 -> Escan(Bscan(e1, e2) +# +# See Icon Analyst 6, pp. 1-2. +# +############################################################################ + +record ScanEnvir(subject, pos) + +procedure Bscan(e1) + local OuterEnvir + OuterEnvir := ScanEnvir(&subject, &pos) + &subject := e1 + &pos := 1 + suspend OuterEnvir + &subject := OuterEnvir.subject + &pos := OuterEnvir.pos + fail +end + +procedure Escan(OuterEnvir, e2) + local InnerEnvir + InnerEnvir := ScanEnvir(&subject, &pos) + &subject := OuterEnvir.subject + &pos := OuterEnvir.pos + suspend e2 + OuterEnvir.subject := &subject + OuterEnvir.pos := &pos + &subject := InnerEnvir.subject + &pos := InnerEnvir.pos + fail +end diff --git a/ipl/procs/scanset.icn b/ipl/procs/scanset.icn new file mode 100644 index 0000000..14b6187 --- /dev/null +++ b/ipl/procs/scanset.icn @@ -0,0 +1,68 @@ +############################################################################ +# +# File: scanset.icn +# +# Subject: Procedures setup for string scanning procedures +# +# Author: Robert J. Alexander +# +# Date: June 4, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Procedure to set up for user-written string-scanning procedures that +# are in the spirit of Icon's built-ins. +# +# The values passed are the s, i1, i2 parameters which are the last +# three arguments to all Icon scanning functions (such as +# upto(c,s,i1,i2)). scan_setup() supplies any appropriate defaults and +# returns needed values. +# +# The value returned is a "scan_setup_result" record consisting of two +# values: +# +# 1. The substring of s to be scanned (ss). +# 2. The size of the substring of s that precedes the +# substring to be scanned (offset). +# +# scan_setup() fails if i1 or i2 is out of range with respect to s. +# +# The user-written procedure can then match in the string ss to compute +# the position within ss appropriate to the scan (p). The value +# returned (or suspended) to the caller is p + offset (the position +# within the original string, s). +# +# For example, the following function finds two words separated by +# spaces: +# +# procedure two_words(s,i1,i2) +# local x,p +# x := scan_setup(s,i1,i2) | fail # fail if out of range +# x.ss ? suspend { +# tab(upto(&letters)) & +# pos(1) | (move(-1) & tab(any(~&letters))) & +# p := &pos & # remember starting position +# tab(many(&letters)) & +# tab(many(' ')) & +# tab(many(&letters)) & +# p + x.offset # return position in original s +# } +# end +# + +record scan_setup_result( + ss, # substring to be scanned + offset) # length of substring preceding ss + +procedure scan_setup(s,i1,i2) + if /s := &subject then + /i1 := &pos + else + /i1 := 1 + /i2 := 0 + return scan_setup_result(s[i1:i2],match("",s,i1,i2) - 1) +end diff --git a/ipl/procs/segment.icn b/ipl/procs/segment.icn new file mode 100644 index 0000000..4dcf0c8 --- /dev/null +++ b/ipl/procs/segment.icn @@ -0,0 +1,60 @@ +############################################################################ +# +# File: segment.icn +# +# Subject: Procedures to segment string +# +# Author: William H. Mitchell +# +# Date: June 10, 1988 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures segment a string s into consecutive substrings +# consisting of characters that respectively do/do not occur in c. +# segment(s,c) generates the substrings, while seglist produces a list +# of the segments. For example, +# +# segment("Not a sentence.",&letters) +# +# generates +# +# "Not" +# " " +# "a" +# " " +# "sentence" +# "." +# while +# seglist("Not a sentence.",&letters) +# +# produces +# +# ["Not"," ","a","sentence","."] +# +############################################################################ + +procedure segment(line,dlms) + local ndlms + + dlms := (any(dlms,line[1]) & ~dlms) + ndlms := ~dlms + line ? repeat { + suspend tab(many(ndlms)) \ 1 + suspend tab(many(dlms)) \ 1 + pos(0) & break + } +end + +procedure seglist(s,c) + local L + + L := [] + c := (any(c,s[1]) & ~c) + s ? while put(L,tab(many(c := ~c))) + return L +end diff --git a/ipl/procs/senten1.icn b/ipl/procs/senten1.icn new file mode 100644 index 0000000..180c249 --- /dev/null +++ b/ipl/procs/senten1.icn @@ -0,0 +1,236 @@ +############################################################################ +# +# File: senten1.icn +# +# Subject: Procedure to generate sentences +# +# Author: Peter A. Bigot +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# sentence(f) generates the English sentences encountered in a file. +# +############################################################################ +# +# The following rules describe what a 'sentence' is. +# +# * A sentence begins with a capital letter. +# +# * A sentence ends with one or more of '.!?', subject to other +# constraints. +# +# * If a period is immediately followed by: +# - a digit +# - a letter +# - one of ',;:' +# it is not a sentence end. +# +# * If a period is followed (with intervening space) by a lower case +# letter, it is not a sentence end (assume it's part of an abbreviation). +# +# * The sequence '...' does not end a sentence. The sequence '....' does. +# +# * If a sentence end character appears after more opening parens than +# closing parens in a given sequence, it is not the end of that +# particular sentence. (I.e., full sentences in a parenthetical remark +# in an enclosing sentence are considered part of the enclosing +# sentence. Their grammaticality is in question, anyway.) (It also +# helps with attributions and abbreviations that would fail outside +# the parens.) +# +# * No attempt is made to ensure balancing of double-quoted (") material. +# +# * When scanning for a sentence start, material which does not conform is +# discarded. +# +# * Corollary: Quotes or parentheses which enclose a sentence are not +# considered part of it. +# +# * An end-of-line on input is replaced by a space unless the last +# character of the line is 'a-' (where 'a' is any letter), in which case +# the hyphen is deleted. +# +# * Leading and trailing space (tab, space, newline) chars are removed +# from each line of the input. +# +# * If a blank line is encountered on input while scanning a sentence, +# the scan is aborted and search for a new sentence begins (rationale: +# ignore section and chapter headers separated from text by newlines). +# +# * Most titles before names would fail the above constraints. They are +# special-cased. +# +# * This does NOT handle when a person uses their middle initial. To do +# so would rule out sentences such as 'It was I.', Six of one, half-dozen +# of the other--I made my choice. +# +# * Note that ':' does not end a sentence. This is a stylistic choice, +# and can be modified by simply adding ':' to sentend below. +# +############################################################################ + +procedure sentence (infile) + local + line, # Line read from input, beginning could be sent. + sentence, # A possible sentence + lstend, # Position in line of last checked sentence end + possentp, # Boolean: non-null if line mod context = sent. + spaceskip, # Spaces betwen EOSent and next char (context) + nextch, # Next char after EOSent + cnt, # Balanced count of parens in possible sent. + t, + newline + static + sentend, # Cset for sentence end chars + wspace, # White space characters + noperend, # Chars which, after period, don't end sentence + titles # Titles that can appear before names. + initial { + sentend := '.?!' # Initial value for sentend + wspace := ' \t\n' # Space chars + noperend := &digits ++ &letters ++ ',:;' # No-end after period chars + titles := ["Mr.", "Mrs.", "Ms.", "Dr.", "Prof.", "Pres."] + } + + line := "" + # Repeat scanning for and suspending sentences until input fails. + repeat { + # Try to find the start of a sentence in the current input string. + # If there are none, read more from file; fail if file exhausted. + # Trim trailing space from line (leading skipped by sentence start) + while not (line ?:= (tab (upto (&ucase)) & tab (0))) do { + line := trim (read (infile), wspace) | fail + } + + # Find the sentence end. If there's no viable candidate, read more + # from input. Set the last end position to the first char in the + # sentence. + lstend := 1 + possentp := &null + repeat { + line ? { + # Skip up to new stuff (scanned in previous lines). + sentence := tab (lstend) + while sentence ||:= tab (upto (sentend)) do { + sentence ||:= tab (many (sentend)) + + # Verify end-of-sentence. Assume it doesn't pass. + possentp := &null + + # Check for sentence end conformance. See what follows it: put + # that in nextch, and the intervening space before it in + # spaceskip. + # Note hack to scan in remainder of line w/o changing &pos. + nextch := &null + every tab (0) ? { + spaceskip := tab (many (wspace)) | "" + nextch := move (1) + } + + if /nextch then { + # Don't have enough context to ensure a proper sentence end. + # Read more, but let readers know that this could be a + # sentence end (e.g., in case of EOF on input). + possentp := 1 + break + } + + # Save position of last checked sentence end, so we don't try to + # recheck this one. + lstend := &pos + + # .<noperend> doesn't end a sentence. + if (sentence [-1] == '.' & + spaceskip == "" & + any (noperend, nextch)) then { + next + } + + # .<spc><lcase> doesn't end sentence + if (sentence [-1] == '.' & + any (&lcase, nextch)) then { + next + } + + # ... doesn't end sentence. .... does. + if (sentence [-3:0] == "..." & + sentence [-4] ~== ".") then { + next + } + + # Number of ')' must be >= number '(' in sentence. + sentence ? { + cnt := 0 + while tab (upto ('()')) do { + if ="(" then { + cnt +:= 1 + } + else { + =")" + cnt -:= 1 + } + } + } + if (cnt > 0) then { + next + } + + # Special case titles that appear before names (otherwise look + # like sentence ends). + every t := ! titles do { + if (t == sentence [- *t:0]) then { + # Break every, next in sentence-end search repeat + break next + } + } + + # This is a sentence. Replace the line with what follows the + # sentence, and break out of the sentence-end-search loop. + line := tab (0) + break break + } + } + # There is no valid sentence end so far. Remove a trailing hyphen + # from the current line, or add a word-separating space. + if line [-1] == '-' & any (&letters, line [-2]) then { + line := line [1:-1] + } + else { + line ||:= " " + } + + # Read another line. If can't, then fail--but suspend sentence first + # if it _could_ be a sentence end. Trim leading and trailing spaces + # from the new line--if it's empty, toss the line so far and restart; + # otherwise, tack it onto the end of the current line. + if not (newline := read (infile)) then { + if \possentp then { + suspend (sentence) + } + fail + } + if any (wspace, newline) then { + newline ?:= (tab (many (wspace)), tab (0)) + } + newline := trim (newline, wspace) + if (*newline = 0) then { + if \possentp then { + suspend (sentence) + } + line := "" + # Break EOS check, next beginning-of-sent scan + break next + } + line ||:= newline + } + + # Suspend the sentence, then loop back for more. + suspend sentence + } + end # procedure sentence diff --git a/ipl/procs/sentence.icn b/ipl/procs/sentence.icn new file mode 100644 index 0000000..f80def3 --- /dev/null +++ b/ipl/procs/sentence.icn @@ -0,0 +1,160 @@ +############################################################################ +# +# File: sentence.icn +# +# Subject: Procedure to generate sentences in file +# +# Author: Richard L. Goerwitz +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.2 +# +############################################################################ +# +# sentence(f) - suspends sentences from file f +# +# A lot of grammatical and stylistic analysis programs are predicated +# on the notion of a sentence. For instance, some programs count the +# number of words in each sentence. Other count the number and length +# of clauses. Still others pedantically check for sentence-final par- +# ticles and prepositions. +# +# This procedure, sentence(), is supposed to be used as a filter for +# ASCII text files, suspending everything that looks remotely like a +# sentence in them. +# +############################################################################ +# +# BUGS: Cannot correctly parse sentences with constructs like "R. L. +# Goerwitz" in them. The algorithm can be much improved simply by +# checking to see if the word after the period is in /usr/dict/words +# or whatever your system dictionary file is. If it isn't, then it's +# likely not to be the beginning of a sentence (this also is not in- +# fallible, naturally). +# +############################################################################ +# +# Requires: co-expressions +# +############################################################################ + + +procedure sentence(intext) + + local sentence, get_line, line, tmp_s, end_part, whole_thing + static inits, punct + initial { + inits := &ucase ++ &digits + punct := ".\"'!?)]" + } + sentence := "" + get_line := create read_line(intext) + + while line := @get_line do { + + # If we hit a blank line, it's a signal from read_line that we + # have encountered a change in the indentation level, and + # should call it a sentence break (though it could just be + # indentation for a quote, a section header, etc., it seems + # these all indicate major, sentence-like divisions in the + # text). + if line == "" then { + suspend sentence + sentence := "" + next + } + + # Go on until you can't find any more sentence-endings in line, + # then break and get another line. + repeat { + + # Scan for a sentence break somewhere in line. + line ? { + + # Ugly, but it works. Look for sequences containing + # things like periods and question marks, followed by + # a space and another space or a word beginning with + # a capital letter. If we don't have enough context, + # append the next line from intext to line & scan again. + if tmp_s := tab(upto(punct)) & + upto('!?.', end_part := tab(many(punct))) & + not (pos(-1), line ||:= @get_line, next) & + =" " & (=" " | (tab(many('\'"('))|&null,any(inits))) + # IF YOU WANT TO ADD A DICTIONARY CHECK, then read in + # a dictionary like /usr/dict/words, and then change + # any(inits) above to something like (any(inits), + # longstr(list_of_usrdictwords,map(&subject),&pos), =" ") + # where longstr() matches each string in list_of_usr- + # dictwords. + then { + + # Don't bother with little two-letter hunks. + whole_thing := sentence || tmp_s || end_part + if *whole_thing > 3 | find(" ",whole_thing) + then suspend whole_thing + + tab(many(' ')) + line := tab(0) + sentence := "" + next + } + else break + } + } + + # Otherwise just tack line onto sentence & try again. + sentence ||:= line + } + + return sentence + +end + + + + +procedure read_line(intext) + + local new_line, ilevel, junk_count, space_count, line + static last_ilevel, blank_flag + last_ilevel := 0 + + while line := trim(!intext,'\t ') do { + + # Check to see if line is blank; if so, set blank_flag. + if line == "" then + { blank_flag := 1; next } + + # Determine current indentation level. + detab(line) ? { + ilevel := *tab(many(' ')) | 0 + } + + line ? { + + tab(many('\t ')) + + # Signal the calling procedure if there is a change in the + # indentation level by suspending a blank line. + if (ilevel > last_ilevel) | (ilevel < last_ilevel, \blank_flag) + then suspend "" + last_ilevel := ilevel + + # Put a space on the end of line, unless it ends in a dash. + new_line := tab(-1) || (="-" | (move(1) || " ")) + # Make sure the flag that indicates blank lines is unset. + blank_flag := &null + } + + # Suspend the newly reformatted, trimmed, space-terminated line. + suspend new_line + } + +end diff --git a/ipl/procs/seqfncs.icn b/ipl/procs/seqfncs.icn new file mode 100644 index 0000000..b77a079 --- /dev/null +++ b/ipl/procs/seqfncs.icn @@ -0,0 +1,30 @@ +############################################################################ +# +# File: seqfncs.icn +# +# Subject: Procedures for designing with sequences +# +# Author: Ralph E. Griswold +# +# Date: September 30, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Links: genrfncs, lterps, math, numbers, partit, pdco, seqops, strings, +# convert +# +############################################################################ + +link convert +link genrfncs +link lterps +link math +link numbers +link partit +link pdco +link seqops +link strings diff --git a/ipl/procs/seqimage.icn b/ipl/procs/seqimage.icn new file mode 100644 index 0000000..7ff9b2a --- /dev/null +++ b/ipl/procs/seqimage.icn @@ -0,0 +1,64 @@ +############################################################################ +# +# File: seqimage.icn +# +# Subject: Procedures to produce string image of Icon result sequence +# +# Author: Ralph E. Griswold +# +# Date: June 20, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# The procedure Seqimage{e,i,j} produces a string image of the +# result sequence for the expression e. The first i results are +# printed. If i is omitted, there is no limit. If there are more +# than i results for e, ellipses are provided in the image after +# the first i. If j is specified, at most j results from the end +# of the sequence are printed after the ellipses. If j is omitted, +# only the first i results are produced. +# +# For example, the expressions +# +# Seqimage{1 to 12} +# Seqimage{1 to 12,10} +# Seqimage{1 to 12,6,3} +# +# produce, respectively, +# +# {1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12} +# {1, 2, 3, 4, 5, 6, 7, 8, 9, 10, ...} +# {1, 2, 3, 4, 5, 6, ..., 10, 11, 12} +# +# +# Warning: If j is not omitted and e has an infinite result sequence, +# Seqimage{} does not terminate. +# +############################################################################ + +procedure Seqimage(L) + local seq, result, i, j, resid + + seq := "" + i := @L[2] + j := @L[3] + while result := image(@L[1]) do + if *L[1] > \i then { + if /j then { + seq ||:= ", ..." + break + } + else { + resid := [", " || result] + every put(resid,", " || image(|@L[1])) + if *resid > j then seq ||:= ", ..." + every seq ||:= resid[*resid -j + 1 to *resid] + } + } + else seq ||:= ", " || result + return "{" || seq[3:0] || "}" | "{}" +end diff --git a/ipl/procs/seqops.icn b/ipl/procs/seqops.icn new file mode 100644 index 0000000..f696111 --- /dev/null +++ b/ipl/procs/seqops.icn @@ -0,0 +1,1618 @@ +############################################################################ +# +# File: seqops.icn +# +# Subject: Procedures to manipulate T-sequences +# +# Author: Ralph E. Griswold +# +# Date: March 4, 2003 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures perform operations related to T-Sequences and to +# analyze T-Sequences. +# +############################################################################ +# +# Requires: Courage. +# +############################################################################ +# +# copyl(xargs[]) copy list of lists +# eval_tree(n) evaluate expression tree +# expression_tree(n) create expression tree +# fragment(s, i, p, arg) +# get_analysis(s) analyze sequence +# get_scollate(s) analyze for collation +# get_splace(s) analyze for motif along a path +# get_srepeat(s) analyze for repeat +# get_srun(s) analyze for run +# get_sruns(s) analyze for simple runs +# is_scompact(x) test sequence for compactness +# pimage(x) +# remod(s, p) +# sanalout() output analysis +# sanalysis(x) over-all analysis +# sbefriend(x, p) befriend sequence +# sbinop(op, xargs[]) binary operation on terms +# sbound(xargs[]) compute sequence upper bound FIX! +# scollate(xargs[]) sequence collation +# scompress(xargs[]) compact sequence +# sconcat(xargs[]) concatenate sequences +# sconcatp(xargs[]) concatenate sequences, pattern style +# scpal(xargs[]) closed sequence palindrome +# sdecimate(xargs[]) decimate sequence +# sdecollate(order, x) decollate sequence +# sdelta(x) get delta sequence +# sdirection(x) "direction" of delta(x) +# sequiv(x1, x2) test sequence equivalence +# sextend(xargs[]) extend sequence +# sflatten(x) flatten nested sequence +# sground(s, i) ground sequence to i +# shaft_period(x1, x2) shaft period +# simage(x, limit) string image of sequence +# sinit() initialize sequence operations +# sintermix(xargs[]) intermix sequences +# slayer(xargs[]) layer sequences +# slength(x) compute sequence length +# slocate(xargs[]) sequences of first positions of terms +# smap(xargs[]) map terms in sequence +# smin(xargs[]) compute sequence lower bound FIX +# smissing(x) missing terms in sequence BOGUS?? +# smod(xargs[]) modular reduction +# smutate(xargs[]) mutation +# snormal(x) normalize sequence +# sopal(xargs[]) create open sequence palindrome +# sorder(x) positions of first occurrence +# sparity(xargs[]) adjust parity +# speriod(s, i) sequence period +# splace(xargs[]) place motif along a path +# splaceg(xargs[]) generalized motifs along a path +# splacep(xargs[]) place motif along a path +# ssplitdupl(xargs[]) split duplicate adjacent terms +# spositions(x1, x2) shaft positions +# spromote(x) promote term to sequence +# srandom(x) random selection +# sreflecth(xargs[]) reflect sequence horizontally +# sreflectr(xargs[]) +# sreflectv(xargs[]) reflect sequence vertically +# sremdupl(xargs[]) remove duplicate adjacent terms +# srepeat(xargs[]) repeat sequence +# srepl(xargs[]) replicate sequence terms +# srotatev(xargs[]) rotate sequence vertically +# srun(xargs[]) create connected run +# sruns(xargs[]) create simple runs +# sscale(xargs[]) scale terms in sequence +# sscollate(xargs[]) collate entire sequences +# sselect(xargs[]) select terms from sequence +# sshift(x, i) shift terms sequence +# sundulate(x) make undulating sequence +# sunmod(x) modular expansion +# sunop(op, xargs[]) unary operation on terms +# walk_tree(n, tree_list, tree_ptrs, depth) +# walk expression tree +# +############################################################################ +# +# Links: factors, numbers +# +############################################################################ + +link factors +link numbers + +global expressions +global node_gen +global saltparity +global scompact +global sfliph +global sflipv +global sflipr +global sflipl + +record node(name, seqlist) + +$define MaxTerms 300 + +procedure copyl(xargs[]) #: copy list of lists + local new_xargs + + new_xargs := [] + + every put(new_xargs, copy(spromote(!xargs))) + + return new_xargs + +end + +procedure eval_tree(n) + local i + + n := integer(n) + + if type(n) ~== "node" then return n + + every i := 1 to *n.seqlist do + n.seqlist[i] := eval_tree(n.seqlist[i]) + + return n.name ! n.seqlist + +end + +procedure expression_tree(n) + local result + + n := integer(n) + + case type(n) of { + "list" | "integer" : return "[" || simage(n, MaxTerms) || "]" + "string" : return n + } + + result := n.name || "(" + + every result ||:= expression_tree(!n.seqlist) || "," + + return result[1:-1] || ")" + +end + +procedure fragment(s, i, p, arg) + local results, j, k + + if *s <= i then return s + + /p := 1 + + results := list(i) + + every !results := [] + + k := 0 + + every j := 1 to i do + every 1 to *s / i do + put(results[j], s[k +:= 1]) | break break + + every j := 1 to i do + results[j] := p(results[j], arg) + + every j := 1 to i do + results[j] := fragment(results[j], i, p, arg) + + return results + +end + +$define MinLength 5 # minimum length for attempting analysis + +procedure get_analysis(seq) + local expression + + if *seq < MinLength then return simageb(seq) + + expression := ( + get_scollate(seq) | + get_srepeat(seq) | + remod(seq, get_srun) | # before sruns(), which would subsume it + remod(seq, get_sruns) | + get_splace(seq) | # would subsume some runs + simageb(seq) + ) + + return expression + +end + +procedure get_scollate(seq) #: find collation in sequence + local bound, deltas, i, j, poses, positions, oper, seqs + local results, result, k, count, oseq, m, nonperiod, facts, period + + bound := (sbound ! seq) + + speriod(seq) | fail # only handle periodic case + + deltas := table() + positions := table() + + every i := 1 to bound do { + poses := spositions(seq, i) + positions[i] := poses + j := sconstant(sdelta(poses)) | fail # CONTRADICTION + /deltas[j] := [] + put(deltas[j], i) + } + + oseq := list(*seq, 1) # decollation order sequence + + count := 0 + + every k := key(deltas) do { + count +:= 1 + every j := !deltas[k] do + every m := !positions[j] do + oseq[m] := count + } + + if *set(oseq) < 2 then fail # not enough sequences + +# oseq := srun([1, get(facts)]) | fail + + seqs := sdecollate(oseq, seq) | fail + + oper := "scollate(" || (simageb(oseq[1+:speriod(oseq)]) | + get_analysis(oseq)) + + every oper ||:= ", " || get_analysis(!seqs) + + return oper || ")" + +end + +procedure get_splace(seq) #: find motif along a path in sequence + local i, j, motif, seq2, path + + if i := sconstant(seq) then return "srepeat(" || i || "," || *seq || ")" + + every i := divisors(*seq) do { + motif := seq[1+:i] + every j := i + 1 to *seq by i do + if not sequiv(motif, sground(seq[j+:i], seq[1])) then break next + path := [] + every put(path, seq[1 to *seq by i]) + return "splace(" || get_analysis(motif) || ", " || get_analysis(path) || ")" + } + + fail + +end + +procedure get_srepeat(seq) #: find repeat in sequence + local i + + i := speriod(seq) | fail + return "srepeat(" || get_analysis(seq[1+:i]) || ", " || (*seq / i) || ")" + +end + +procedure get_srun(seq) + local i, j, new_seq, dir + + seq := copy(seq) + + i := get(seq) + j := get(seq) + + if j = i - 1 then dir := -1 # down going + else if j = i + 1 then dir := 1 # upgoing + else fail + + new_seq := [i] + + while i := get(seq) do { + if i = j + 1 then { + if dir = -1 then put(new_seq, j) + dir := 1 + } + else if i = j - 1 then { + if dir = 1 then put(new_seq, j) + dir := -1 + } + else { + put(new_seq, j) + push(seq, i) # put back non-continuing value + break + } + j := i + } + + if *seq ~= 0 then fail + + put(new_seq, j) + + return "srun(" || get_analysis(new_seq) || ")" + +end + +procedure get_sruns(seq) + local i, j, seq1, seq2, dir + + seq1 := [] + seq2 := [] + + repeat { + i := get(seq) | { + put(seq2, j) + break # end of road + } + j := get(seq) | fail # isolated end point + if j = i - 1 then dir := -1 # down going + else if j = i + 1 then dir := 1 # up going + else fail + put(seq1, i) # beginning point + while i := get(seq) do { + if i = j + dir then { + j := i + next + } + else { + push(seq, i) # put back next value + put(seq2, j) + break + } + } + } + + return "sruns(" || get_analysis(seq1) || ", " || get_analysis(seq2) || ")" + +end + +procedure is_scompact(x) #: test sequence for compactness + local bound + + x := spromote(x) + + bound := sbound ! x + + if bound = *set(x) then return bound + else fail + +end + +procedure pimage(s) # DOES THIS BELONG HERE? + local result, x + + result := "" + + every x := !s do { + if integer(x) then result ||:= x else + result ||:= pimage(x) + result ||:= "," + } + + return "[" || result[1:-1] || "]" + +end + +procedure remod(seq, p) #: handle modulus + local nseq, bound + + nseq := sunmod(seq) + + if (sbound ! nseq) > (bound := sbound ! seq) then + return "smod(" || p(nseq) || ", " || bound || ")" + else return p(copy(seq)) + +end + +procedure sanalout() + local expression, var + + write("link seqops") + write("procedure main()") + + expressions := sort(expressions, 4) + + while expression := get(expressions) do + write(var := get(expressions), " := ", expression) + + write("every write(!", var, ")") + + write("end") + + expressions := table() + + return + +end + +procedure sanalysis(x) + +# sanalyze(x) + + sanalout() + + return + +end + +procedure sbinop(op, xargs[]) #: binary operation on terms + local lseq, i, x1, x2 + + x1 := spromote(xargs[1]) + x2 := spromote(xargs[2]) + + op := proc(op, 2) | fail + + lseq := [] + + every i := 1 to smin(*x1, *x2) do + put(lseq, op(x1[i], x2[i])) + + return lseq + +end + +procedure sbound(xargs[]) #: compute sequence upper bound FIX! + + return sort(xargs)[-1] + +end + +procedure scollate(xargs[]) #: sequence term collation + local lseq, i, order + + if \node_gen then return node("scollate", xargs) + + order := get(xargs) + + /order := srun(1, *xargs) + + xargs := copyl ! xargs + + lseq := [] + + while i := get(order) do { + put(order, i) + put(lseq, get(xargs[i])) | break + } + + put(lseq, get(xargs[get(order)])) # ????? + + return lseq + +end + +procedure scompress(xargs[]) #: compact sequence + local unique, target, x + + if \node_gen then return node("compress", xargs) + + x := spromote(xargs[1]) + + unique := set(x) + + target := [] + + every put(target, 1 to *unique) + + return smap(x, sort(unique), target) + +end + +procedure sconcat(xargs[]) #: concatenate sequences + local lseq + + if \node_gen then return node("sconcat", xargs) + + lseq := [] + + every lseq |||:= spromote(!xargs) + + return lseq + +end + +procedure sconcatp(xargs[]) #: concatenate sequences as pattern + local lseq, nseq + + if \node_gen then return node("sconcat", xargs) + + lseq := [] + + every nseq := spromote(!xargs) do { + if nseq[1] === lseq[-1] then get(nseq) + lseq |||:= nseq + } + + return lseq + +end + +procedure sconstant(seq) #: test for constant sequence + + if *set(seq) = 1 then return !seq + else fail + +end + +procedure scpal(xargs[]) #: closed sequence palindrome + local lseq, x1, x2, i + + if \node_gen then return node("scpal", xargs) + + x1 := spromote(xargs[1]) + x2 := spromote(xargs[2]) | [1] + + i := 0 + + every i +:= !x2 + + lseq := srepeat(sopal(x1), i) + + put(lseq, lseq[1]) + + return lseq + +end + +procedure sdecimate(xargs[]) #: decimate sequence + local lseq, j, k, x1, x2 + + x1 := spromote(xargs[1]) + x2 := sort(spromote(xargs[2])) + + lseq := [] + + k := 1 + + while j := get(x2) do { + every put(lseq, x1[k to j - 1]) + k := j + 1 + } + + every put(lseq, x1[j + 1 to *x1]) + + return lseq + +end + + +procedure sdecollate(order, x) #: sequence decollation + local lseq, i, j + + x := spromote(x) + + if *x = 0 then fail + + order := copy(order) + + lseq := list(sbound ! order) # list of lists to return + + every !lseq := [] # initially empty + + every j := !x do { + i := get(order) | fail + put(order, i) + put(lseq[i], j) + } + + return lseq + +end + +procedure sdelta(seq) #: sequence delta + local i, lseq, j + + if *seq < 2 then fail + + seq := copy(seq) + + i := get(seq) + + lseq := [] + + while j := get(seq) do { + put(lseq, j - i) + i := j + } + + return lseq + +end + +procedure sdirection(x) #: sequence delta "direction" + local lseq, i + + x := sdelta(spromote(x)) | fail + + lseq := [] + + while i := get(x) do + put(lseq, + if i > 0 then 3 + else if i = 0 then 2 + else 1 + ) + + return lseq + +end + +procedure sdistrib(x) + local lseq, i + + x := copy(spromote(x)) + + lseq := list(sbound ! x, 0) + + while i := get(x) do + lseq[i] +:= 1 + + return lseq + +end + +procedure sequiv(x1, x2) # test for sequence equivalence + local i + + x1 := spromote(x1) + x2 := spromote(x2) + + if *x1 ~= *x2 then fail + + every i := 1 to *x1 do + if x1[i] ~= x2[i] then fail + + return x2 + +end + +procedure sextend(xargs[]) #: extend sequence + local lseq, part, i, x1, x2 + + if \node_gen then return node("sextend", xargs) + + x1 := spromote(xargs[1]) + + lseq := [] + + every i := !spromote(xargs[2]) do { + part := [] + until *part >= i do + part |||:= x1 + lseq |||:= part[1+:i] + } + + return lseq + +end + +procedure sflatten(s) # flatten packet sequence BELONGS HERE? + local lseq, x + + lseq := [] + + every x := !s do + if type(x) == "list" then lseq |||:= sflatten(x) + else put(lseq, x) + + return lseq + +end + +procedure sground(seq, i) #: ground sequence to i + local j + + /i := 1 + + j := smin ! seq + + every !seq -:= (j - i) + + return seq + +end + +procedure shaft_period(x1, x2) #: shaft period + local results + + x1 := spromote(x1) + x2 := spromote(x2) + + return sconstant(sdelta(spositions(x1, x2))) + +end + +procedure simage(x, limit) #: string image of sequence + local str + + x := spromote(x) + + if *x = 0 then return "[]" + + /limit := 2 ^ 16 # good enough + + str:= "" + + every str ||:= (!x \ limit) || ", " + + if *x > limit then str ||:= "... " + + return str[1:-2] + +end + +procedure simageb(seq) #: bracketed sequence image + + if *seq = 1 then return seq[1] + + return "sconcat(" || simage(seq) || ")" + +end + +procedure sinit() #: initialize sequence operations + + saltparity := sparity + scompact := scompress + sfliph := sreflecth + sflipv := sreflectv + sflipr := sreflectr +# sflipl := sreflectl + + return + +end + +procedure sintermix(xargs[]) #: sequence intermixing + local lseq, i, order + + if \node_gen then return node("sintermix", xargs) + + order := get(xargs) + + /order := srun(1, *xargs) + + xargs := copyl ! xargs + + lseq := [] + + while i := get(order) do { + put(order, i) + lseq |||:= xargs[i] + } + + return lseq + +end + +procedure slayer(xargs[]) #: layer sequences + local new_xargs, i, shift + + if \node_gen then return node("slayer", xargs) + + new_xargs := [xargs[1], xargs[2]] | fail + + if not integer(xargs[2][1]) then return scollate ! xargs + + shift := sbound ! xargs[2] + + every i := 3 to *xargs do { + put(new_xargs, sshift(xargs[i], shift)) + shift +:= sbound ! xargs[i] + } + + return scollate ! new_xargs + +end + +procedure slength(x) #: compute sequence length + + return *spromote(x) + +end + +procedure slocate(xargs[]) #: sequences of first positions of terms + local count, i, lseq, x1, x2 + + if \node_gen then return node("slocate", xargs) + + x1 := copy(spromote(xargs[1])) + x2 := set(spromote(xargs[2])) + + lseq := [] + + count := 0 + + while i := get(x1) do { + count +:= 1 + if member(x2, integer(i)) then + return count + } + + fail + +end + +procedure smap(xargs[]) #: map terms in sequence + local i, smaptbl, x1, x2, x3 + static tdefault + + initial tdefault := [] + + x1 := copy(spromote(xargs[1])) + x2 := spromote(xargs[2]) + x3 := spromote(xargs[3]) + + if *x2 ~= *x3 then fail + + smaptbl := table(tdefault) # mapping table + + every i := 1 to *x2 do # build the map + smaptbl[x2[i]] := x3[i] + + every i := 1 to *x1 do # map the values + x1[i] := (tdefault ~=== smaptbl[x1[i]]) + + return x1 + +end + +procedure smin(xargs[]) #: compute sequence lower bound FIX + + return sort(xargs)[1] + +end + +procedure smissing(x) #: missing terms in sequence BOGUS?? + local lseq, i, result + + x := spromote(x) + + lseq := sorder(x) + + result := [] + + every i := 1 to *lseq do + if lseq[i] = 0 then put(result, i) + + return result + +end + +procedure smod(xargs[]) #: modular reduction + local lseq, i, x1, x2 + + if \node_gen then return node("smod", xargs) + + x1 := spromote(xargs[1]) + x2 := spromote(xargs[2]) + + lseq := [] + + every i := !x2 do + every put(lseq, residue(!x1, i, 1)) + + return lseq + +end + +procedure smutate(xargs[]) #: mutation + local lseq, x1, x2 + + if \node_gen then return node("smutate", xargs) + + x1 := spromote(xargs[1]) + x2 := spromote(xargs[2]) + + lseq := [] + + every put(lseq, x1[!x2]) + + return lseq + +end + +procedure snormal(x) #: normalize sequence + local lseq, i, target, count # maps shafts so they are numbered in order + # first appearance + x := spromote(x) + + lseq := [] + + count := 0 + + target := table() + + every i := !x do { + /target[i] := (count +:= 1) + put(lseq, target[i]) + } + + return lseq + +end + +procedure sopal(xargs[]) #: create open sequence palindrome + local x + + if \node_gen then return node("sopal", xargs) + + x := spromote(xargs[1]) + + return x ||| sreflecth(x)[2:-1] + +end + +procedure sorder(x) #: positions of first occurrence + local lseq, i, done # of terms in *compact* sequence + + x := copy(spromote(x)) + + lseq := [] + + done := set() + + while i := integer(get(x)) do { + if member(done, i) then next + else { + put(lseq, i) + insert(done, i) + } + } + + return lseq + +end + +procedure sparity(xargs[]) #: adjust parity + local lseq, i, j, k, x1, x2 + + if \node_gen then return node("sparity", xargs) + + x1 := spromote(xargs[1]) + x2 := spromote(xargs[2]) + + lseq := [] + + every i := 1 to *x1 do { + j := x1[i] + k := x2[i] + if (j % 2) = (k % 2) then put(lseq, j) + else put(lseq, j + 1, j) + } + + return lseq + +end + +procedure speriod(seq, k) #: period of sequence + local i, segment + + if /k then { # assume full repeats + every i := 1 | divisors(*seq) do { # if repeats came out even + segment := seq[1+:i] + if sequiv(sextend(segment, *seq), seq) then return i + } + fail + } + else { # assume partial repeat at edge + every i := 1 to *seq do { + segment := seq[1+:i] + if sequiv(sextend(segment, *seq), seq) then return i + } + fail # should not happen + } + +end + +procedure splace(xargs[]) #: place motif along a path + local lseq, i, x1, x2 + + if \node_gen then return node("splace", xargs) + + x1 := copy(spromote(xargs[1])) + x2:= spromote(xargs[2]) + + lseq := [] + + every i := !x2 do + every put(lseq, !x1 + i - 1) + + return lseq + +end + +procedure splacep(xargs[]) #: place motif along a path + local lseq, i, x1, x2, j + + if \node_gen then return node("splace", xargs) + + x1 := copy(spromote(xargs[1])) + x2:= spromote(xargs[2]) + + lseq := [] + + every i := !x2 do { + j := x1[1] + if j ~= lseq[-1] then put(lseq, j) + every put(lseq, x1[2 to * x1] + i - 1) + } + + return lseq + +end + +procedure splaceg(xargs[]) #: generalized motifs along a path + local lseq, i, path, motif + + if \node_gen then return node("splaceg", xargs) + + path := copy(get(xargs)) + + xargs := copyl ! xargs + + lseq := [] + + while i := get(path) do { + motif := get(xargs) + put(xargs, motif) + every put(lseq, !motif + i - 1) + } + + return lseq + +end + +procedure spositions(x1, x2) #: positions of values in sequence + local lseq, count, i + + x1 := copy(spromote(x1)) + x2 := set(spromote(x2)) + + lseq := [] + + count := 0 + + while i := get(x1) do { + count +:= 1 + if member(x2, integer(i)) then + put(lseq, count) + } + + return lseq + +end + +procedure spromote(x) #: promote term to sequence + + if type(x) ~== "list" then x := [x] + + return x + +end + +procedure srandom(x) #: random selection + + return ?spromote(x) + +end + +procedure sreflecth(xargs[]) #: reflect sequence horizontally + local lseq, x + + if \node_gen then return node("sreflecth", xargs) + + lseq := [] + + every push(lseq, !spromote(xargs[1])) + + return lseq + +end + + +procedure sreflectr(xargs[]) + local lseq, i, bound, x + + if \node_gen then return node("sreflectr", xargs) + + x := spromote(xargs[1]) + + bound := sbound ! x + + lseq := [] + + every i := !x do + push(lseq, bound - i + 1) + + return lseq + +end + +procedure sreflectv(xargs[]) #: reflect sequence vertically + local lseq, m, x + + if \node_gen then return node("sreflectv", xargs) + + x := spromote(xargs[1]) + + if not integer(x[1]) then return x + + m := sbound ! x + + lseq := [] + + every put(lseq, m - !x + 1) + + return lseq + +end + +procedure sremdupl(xargs[]) #: remove duplicate adjacent terms + local lseq, i, x + + if \node_gen then return node("sremdupl", xargs) + + x := copy(spromote(xargs[1])) + + lseq := [get(x)] | return [] + + while i := get(x) do + if lseq[-1] ~= i then + put(lseq, i) + + return lseq + +end + +procedure ssplitdupl(xargs[]) #: split duplicate adjacent terms + local lseq, i, x + + if \node_gen then return node("sremdupl", xargs) + + x := copy(spromote(xargs[1])) + + lseq := [get(x)] | return [] + + while i := get(x) do + if lseq[-1] ~= i then + put(lseq, i) + else + put(lseq, i + 1, i) + + return lseq + +end + +procedure srepeat(xargs[]) #: repeat sequence + local lseq, count, x1, x2 + + if \node_gen then return node("srepeat", xargs) + + x1 := spromote(xargs[1]) + + count := 0 + + every count +:= !spromote(xargs[2]) + + lseq := copy(x1) + + every 2 to count do + lseq |||:= x1 + + return lseq + +end + +procedure srepl(xargs[]) # replicate sequence terms + local lseq, i, j, x1, x2 + + if \node_gen then return node("srepl", xargs) + + x1 := spromote(xargs[1]) + x2 := spromote(xargs[2]) + + lseq := [] + + every i := !x2 do + every j := !x1 do + every 1 to i do + put(lseq, j) + + return lseq + +end + +procedure srotatev(xargs[]) #: rotate sequence vertically + local lseq, m, x + + if \node_gen then return node("srotatev", xargs) + + x := spromote(xargs[1]) + + if not integer(x[1]) then return x + + m := sbound ! x + + lseq := [] + + every put(lseq, residue(!x + 1, m, 1)) + + return lseq + +end + +procedure srun(xargs[]) #: create connected runs + local lseq, i, j, x + + if \node_gen then return node("srun", xargs) + + x := copy(spromote(xargs[1])) + + lseq := [] + + i := get(x) | return lseq + + while j := get(x) do { + lseq |||:= sruns(i, j, 1) + pull(lseq) + i := j + } + + put(lseq, i) + + return lseq + +end + +procedure sruns(xargs[]) # disconnected runs + local lseq, i, j, k, limit, x1, x2, x3 + + if \node_gen then return node("sruns", xargs) + + x1 := copy(spromote(xargs[1])) + x2 := copy(spromote(xargs[2])) + x3 := copy(spromote(xargs[3])) | [1] + + lseq := [] + + repeat { + i := get(x1) | break + j := get(x2) | break + k := get(x3) | break + put(x3, k) # cycle + if integer(j) < integer(i) then k := -k + every put(lseq, i to j by k) + } + + return lseq + +end + +procedure sscale(xargs[]) #: scale terms in sequence + local lseq, j, i, x1, x2 + + if \node_gen then return node("sscale", xargs) + + x1 := spromote(xargs[1]) + + lseq := [] + + every i := !spromote(xargs[2]) do + every j := 1 to *x1 do + put(lseq, (x1[j] - 1) * i + 1) + + return lseq + +end + +procedure sscollate(xargs[]) #: entire sequence collation + local lseq, i, order + + if \node_gen then return node("sscollate", xargs) + + order := get(xargs) + + /order := srun(1, *xargs) + + xargs := copyl ! xargs + + lseq := [] + + while i := get(order) do + lseq |||:= xargs[i] + + return lseq + +end + +procedure sselect(xargs[]) #: select terms from sequence + local lseq, i, x1, x2 + + if \node_gen then return node("sselect", xargs) + + x1 := spromote(xargs[1]) + x2 := copy(spromote(xargs[2])) + + lseq := [] + + while i := get(x2) do + put(lseq, x1[i]) # may fail + + return lseq + +end + +procedure sshift(x, i) #: shift terms sequence + local lseq + + lseq := [] + + every put(lseq, !spromote(x) + i) + + return lseq + +end + +procedure sundulate(x) #: make undulating sequence + local lseq, i, dir + + x := copy(spromote(x)) + + lseq := [get(x)] | fail + + while i := get(x) | return lseq do { + if i > lseq[-1] then { + dir := -1 + break + } + else if i < lseq[-1] then { + dir := 1 + break + } + } + + put(lseq, i) + + while i := get(x) do { + if i < lseq[-1] then { + if dir = -1 then { + put(lseq, i) + dir := 1 + } + else lseq[-1] := i + } + if i > lseq[-1] then { + if dir = 1 then { + put(lseq, i) + dir := -1 + } + else lseq[-1] := i + } + } + + return lseq + +end + +procedure sunmod(x) #: modular expansion + local base, bound, i, lseq, k + + x := copy(spromote(x)) + + if not integer(x[1]) then return x + + base := 0 + + bound := sbound ! x + + lseq := [get(x)] | fail + + while i := get(x) do { + if (i = 1) & (lseq[-1] = base + bound) then + base +:= bound + else if (i = bound) & (lseq[-1] = base + 1) then + base -:= bound + put(lseq, base + i) + } + + while (k := (smin ! lseq)) < 1 do + every !lseq +:= bound + + return lseq + +end + +procedure sunop(op, xargs[]) #: unary operation on terms + local lseq, i, x + + if \node_gen then return node("sunop", xargs) + + x := spromote(xargs[1]) + + op := proc(op, 1) | fail + + lseq := [] + + every i := 1 to *x do + put(lseq, op(x[i])) + + return lseq + +end + +procedure walk_tree(n, tree_list, tree_ptrs, depth) + local indent + + /tree_list := [] + /tree_ptrs := [] + /depth := 0 + + indent := repl(" ", 3 * depth) + + n := integer(n) + + case type(n) of { + "integer" | "list" : { + put(tree_list, indent || "[" || simage(n, MaxTerms) || "]") + put(tree_ptrs, n) + return [tree_list, tree_ptrs] + } + "string" : { + put(tree_list, indent || n) + put(tree_ptrs, n) + return [tree_list, tree_ptrs] + } + } + + put(tree_list, indent || n.name) + put(tree_ptrs, n) + + every walk_tree(!n.seqlist, tree_list, tree_ptrs, depth + 1) + + return [tree_list, tree_ptrs] + +end + +procedure sbefriend(x, way) #: make a sequence friendly + local lseq, i, tail + + /way := connect + + x := copy(spromote(x)) + + put(x, x[1]) # for first-last friendliness + + lseq := [get(x)] | return [] + + while i := get(x) do + lseq |||:= way(lseq[-1], i) + + pull(lseq) # remove added term + + return lseq + +end + +procedure connect(j, i) #: connect friends + local k, result + + result := [] + + k := i - j + + if abs(k) = 1 then put(result, i) + else if k = 0 then + put(result, i + ?[1, -1], i) + else if k > 0 then + every put(result, j + 1 to i) + else + every put(result, j - 1 to i by -1) + + return result + +end + +procedure wander(j, i) #: friendly meander + local result, k, incr + + result := [j] + + repeat { + k := i - result[-1] + if abs(k) = 1 then { + put(result, i) + break + } + incr := [1, -1] + if k < 0 then + every 1 to -k do + put(incr, -1) + else + every put(incr, 1) + put(result, result[-1] + ?incr) + if result[-1] == i then break + } + + if *result > 1 then get(result) + + return result + +end + +procedure sxplot(x) # plot sequence + local plot, i, bound + + x := spromote(x) + + bound := sbound ! x + + plot := list(bound, repl(" ", *x)) + + every i := 1 to *x do + plot[x[i]][ i] := "x" + + while write(pull(plot)) + + return + +end + +procedure sundelta(x) # get undulant from delta sequence + local i + + x := spromote(x) + + every i := 2 to *x by 2 do # change sign of even-numbered terms + x[i] := -x[i] + + return sredelta(x) + +end + +procedure sredelta(x) # reconstruct sequence from delta sequence + local lseq + + x := spromote(x) + + lseq := [1] # nominal base + + while put(lseq, lseq[-1] + get(x)) + + return sground(lseq) # may have gone negative ... + +end + +procedure sreplp(x1, x2) + local lseq, i + + x1 := spromote(x1) + x2 := spromote(x2) + + lseq := [] + + while i := get(x1) do + every 1 to get(x2) do + put(lseq, i) + + return lseq + +end + +procedure sundulant(x, sw) # get undulant + local lseq, i, dir, cdir + + x := spromote(x) + + lseq := [x[1]] | fail + + i := 2 + + repeat { + dir := sign(x[i] - x[i - 1]) | fail + if dir ~= 0 then break + else i +:= 1 + } + + every i := 2 to *x do { + cdir := sign(x[i] - x[i - 1]) + if cdir = 0 then next + if dir ~= cdir then { + put(lseq, x[i - 1]) + dir := cdir + } + } + + if \sw & lseq[1] = lseq[-1] then pull(lseq) # repeating undulant + + if *lseq < 3 then fail # too short + + return lseq + +end diff --git a/ipl/procs/serial.icn b/ipl/procs/serial.icn new file mode 100644 index 0000000..422d25a --- /dev/null +++ b/ipl/procs/serial.icn @@ -0,0 +1,28 @@ +############################################################################ +# +# File: serial.icn +# +# Subject: Procedure to return serial number of structure +# +# Author: Ralph E. Griswold +# +# Date: April 19, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Procedure to return the serial number of a structure. +# +############################################################################ + +procedure serial(x) #: structure serial number + + return image(x) ? { # fails on non-structure or bogus kind + tab(upto('_') + 1) | fail + return integer(tab(many(&digits))) + } + +end diff --git a/ipl/procs/sername.icn b/ipl/procs/sername.icn new file mode 100644 index 0000000..44ba202 --- /dev/null +++ b/ipl/procs/sername.icn @@ -0,0 +1,63 @@ +############################################################################ +# +# File: sername.icn +# +# Subject: Procedure to produce serialized names +# +# Author: Ralph E. Griswold +# +# Date: June 27, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# sername(p, s, n, i) produces a series of names of the form +# p<nnn>s. If n is given it determines the number of digits in +# <nnn>. If i is given it resets the sequence to start with i. <nnn> is +# an right-adjusted integer padded with zeros. +# +# Ordinarily, the arguments only are given on the first call. Subsequent +# calls without arguments give the next name. +# +# For example, sername("image", ".gif", 3, 0) produces "image000.gif", +# and subsequently, sername() produces "image001.gif", image002.gif", +# and so on. +# +# The defaults, if sername() is first called without any arguments is +# as for the call sername("file", 3, 0, ""). +# +# If any argument changes on subsequent calls, all non-null arguments are +# reset. +# +############################################################################ + +procedure sername(p, s, n, i) + static prefix, suffix, cols, serial, name, first + + initial { + prefix := "file" + suffix := "" + cols := 3 + serial := 0 + first := serial + } + + # See if anything has changed. + + if not(p === prefix & s === suffix & n === cols & first === i) then { + prefix := \p + suffix := \s + cols := \n + first := serial := \i + } + + name := prefix || right(serial, cols, "0") || suffix + + serial +:= 1 + + return name + +end diff --git a/ipl/procs/sets.icn b/ipl/procs/sets.icn new file mode 100644 index 0000000..84a972b --- /dev/null +++ b/ipl/procs/sets.icn @@ -0,0 +1,124 @@ +############################################################################ +# +# File: sets.icn +# +# Subject: Procedures for set manipulation +# +# Author: Alan Beale +# +# Date: August 7, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Contributor: Ralph E. Griswold +# +############################################################################ +# +# cset2set(c) returns a set that contains the individual +# characters in cset c. +# +# domain(T) returns the domain of the function defined by the +# table T. +# +# inverse(T, x) returns the inverse of the function defined by the +# table T. If x is null, it's the functional inverse. +# If x is an empty list, it's the relational inverse. +# If x is an empty set, it the relational inverse, but +# with each table member as a set instead of a list. +# +# pairset(T) converts the table T to an equivalent set of ordered +# pairs. +# +# range(T) returns the range of the function defined by the +# table T. +# +# seteq(S1, S2) tests equivalence of sets S1 and S2. +# +# setlt(S1, S2) tests inclusion of set S1 in S2. +# +# simage(S) string image of set +# +############################################################################ + +procedure cset2set(cs) #: set of characters + local result + + result := set() + every insert(result, !cs) + + return result + +end + +procedure pairset(T) #: set of table pairs + return set(sort(T)) +end + +procedure domain(T) #: domain of table + local dom + + dom := set() + every insert(dom, key(T)) + return dom +end + +procedure range(T) #: range of table + local ran + + ran := set() + every insert(ran, !T) + return ran +end + +procedure inverse(T, Default) #: inverse of table function + local inv, delem, relem + + inv := table(Default) + every delem := key(T) do { + if type(Default) == "list" then + if member(inv, relem := T[delem]) then + put(inv[relem], delem) + else inv[relem] := [delem] + else if type(Default) == "set" then + if member(inv, relem := T[delem]) then + insert(inv[relem], delem) + else inv[relem] := set([delem]) + else inv[T[delem]] := delem + } + return inv +end + +procedure seteq(set1, set2) #: set equivalence + local x + + if *set1 ~= *set2 then fail + every x := !set1 do + if not member(set2, x) then fail + return set2 + +end + +procedure setlt(set1, set2) #: set inclusion + local x + + if *set1 >= *set2 then fail + every x := !set1 do + if not member(set2, x) then fail + return set2 + +end + +procedure simage(set) #: string image of set + local result + + result := "" + + every result ||:= image(!set) || ", " + + return "{ " || result[1:-2] || " }" + +end diff --git a/ipl/procs/showtbl.icn b/ipl/procs/showtbl.icn new file mode 100644 index 0000000..3290e1f --- /dev/null +++ b/ipl/procs/showtbl.icn @@ -0,0 +1,109 @@ +############################################################################ +# +# File: showtbl.icn +# +# Subject: Procedure to show contents of a table +# +# Author: Ralph E. Griswold +# +# Date: March 25, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# +# showtbl(title, tbl, sort_type, limit, sort_order, posit, +# w1, w2, gutter, f1, f2) displays tbl according to the arguments given. +# +# The arguments are: +# +# position name meaning default/alternative +# +# 1 title heading title "" +# 2 tbl table to be shown +# 3 sort_type type of sorting "ref"/"val" +# 4 limit lines of table output essentially infinite +# 5 sort_order increasing/decreasing "incr"/"decr" +# 6 posit first column "val"/"ref" +# 7 w1 width of 1st column 10 +# 8 w2 width of 2nd column 10 +# 9 gutter width between columns 3 +# 10 f1 function of 1st column left +# 11 f2 function of 2nd column right +# +# showtbl() returns a record with the first element being a count of +# the size of the table and the second element the number of lines +# written. +# +############################################################################ +# +# This procedure just grew. It needs rewriting. +# And it has far too many arguments. +# +############################################################################ +# +# Deficiencies: Several features are not yet implemented. sort_order +# and posit have no effect. In the case of sort_type +# "val", the sorting order is decreasing. +# +############################################################################ + +procedure showtbl(title, tbl, sort_type, #: show table contents + limit, sort_order, posit, w1, w2, gutter, f1, f2) + local count, lst, i, number + + /title := "" + if type(tbl) ~== "table" then + stop("*** invalid table argument to showtbl()") + sort_type := case sort_type of { + "ref" | &null: 3 + "val": 4 + default: stop("*** invalid sort type in showtbl()") + } + /limit := 2 ^ 30 # essentially infinite + sort_order := case sort_order of { + "incr" | &null: "incr" + "decr": "decr" + default: stop("*** invalid sort order in showtbl()") + } + posit := case posit of { + "val" | &null: "val" + "ref": "ref" + default: stop("*** invalid column position in showtbl()") + } + /w1 := 10 + /w2 := 10 + /gutter := repl(" ", 3) + /f1 := left + /f2 := right + + number := 0 + + count := 0 + every count +:= !tbl + + write("\n", title, ":\n") + + lst := sort(tbl, sort_type) + + if sort_type = 3 then { + every i := 1 to *lst - 1 by 2 do { + number +:= 1 + if number > limit then break + else write(f1(lst[i], w1), gutter, trim(f2(lst[i + 1], w2))) + } + } + else { + every i := *lst to 1 by -2 do { + number +:= 1 + if number > limit then break + else write(f1(lst[i - 1], w1), gutter, trim(f2(lst[i], w2))) + } + } + + return [count, number] + +end diff --git a/ipl/procs/shquote.icn b/ipl/procs/shquote.icn new file mode 100644 index 0000000..b28110a --- /dev/null +++ b/ipl/procs/shquote.icn @@ -0,0 +1,147 @@ +############################################################################ +# +# File: shquote.icn +# +# Subject: Procedures to quote word for UNIX-like shells +# +# Author: Robert J. Alexander +# +# Date: December 30, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# The following procedures are useful for writing Icon programs that +# generate shell commands. Certain characters cannot appear in the +# open in strings that are to be interpreted as "words" by command +# shells. This family of procedures assists in quoting such strings so +# that they will be interpreted as single words. Quoting characters +# are applied only if necessary -- if strings need no quoting they are +# returned unchanged. +# +# shquote(s1, s2, ..., sN) : s -- Produces a string of words s1, s2, +# ..., sN that are properly separated and quoted for the Bourne Shell +# (sh). +# +# cshquote(s1, s2, ..., sN) : s -- Produces a string of words s1, s2, ..., sN +# that are properly separated and quoted for the C-Shell (csh). +# +# mpwquote(s1, s2, ..., sN) : s -- Produces a string of words s1, s2, +# ..., sN that are properly separated and quoted for the Macintosh +# Programmer's Workshop shell (MPW Shell). +# +# dequote(s1,s2) : s3 -- Produces the UNIX-style command line word s1 +# with any quoting characters removed. s2 is the escape character +# required by the shell (s2 defaults the the usual UNIX escape +# character, the backslash "\\"). +# +############################################################################ + +procedure shquote(s[]) + return shquote_words(s) +end + +procedure cshquote(s[]) + s := shquote_words(s,'\t\n $"#&\'()*;<>?[\\`|~') + # + # But backslashes before any bangs (!). + # + s ? { + s := "" + while s ||:= tab(find("!")) do { + s ||:= "\\" || move(1) + } + s ||:= tab(0) + } + return s +end + +procedure mpwquote(s[]) + # + # The following are Macintosh Option- characters that have special + # meaning to the MPW Shell. They are represented here as Icon + # escape sequences rather than as themselves since some + # ASCII-oriented mailers change characters that have their + # high-order bits set. + # + # \xa8 circled r + # \xb3 >= (I/O redirection) + # \xb6 lower case delta (escape character) + # \xb7 upper case sigma + # \xc5 lower case phi + # \xc7 << (I/O redirection) + # \xc8 >> (I/O redirection) + # \xc9 ... + # + local result + result := "" + # + # If there is a "return" in the string, it must be replaced by an + # escape sequence outside of the single quotes. + # + shquote_words(s, + '\0\t\n\r "#&\'()*+/;<>?[\\]`{|}\xa8\xb3\xb6\xb7\xc5\xc7\xc8\xc9', + "\xb6") ? { + while result ||:= tab(find("\x0d")) do { + result ||:= "'\xb6n'" + move (1) + } + result ||:= tab(0) + } + return result +end + +procedure shquote_words(wordList,quotedChars,escapeString,sepString) + local s, result, sep + /quotedChars := '\t\n\r $"#&\'()*;<>?[\\^`|' + /escapeString := "\\" + /sepString := " " + result := sep := "" + every s := !wordList do { + if s == "" | upto(quotedChars,s) then { + s ? { + s := "'" + while s ||:= tab(find("'")) || "'" || escapeString || "''" & move(1) + s ||:= tab(0) || "'" + } + } + result ||:= sep || s + sep := sepString + } + return result +end + +procedure dequote(s,escapeString,escapeProc) + local quoteChars,c,d + /escapeString := "\\" + /escapeProc := 1 + quoteChars := '"\'' ++ escapeString[1] + s ? { + s := "" + while s ||:= tab(upto(quoteChars)) do { + if =escapeString then s ||:= (if d === "'" then escapeString else +escapeProc(move(1))) + else { + c := move(1) + (/d := c) | (s ||:= d ~== c) | (d := &null) + } + } + return s || tab(0) + } +end + +procedure mpwdequote(s) + return dequote(s,"\xb6",mpw_escape_proc) +end + +procedure mpw_escape_proc(ch) + return case ch of { + "n": "\n" + "t": "\t" + "f": "\f" + default: ch + } +end diff --git a/ipl/procs/signed.icn b/ipl/procs/signed.icn new file mode 100644 index 0000000..93308b9 --- /dev/null +++ b/ipl/procs/signed.icn @@ -0,0 +1,44 @@ +############################################################################ +# +# File: signed.icn +# +# Subject: Procedure to put bits into signed integer +# +# Author: Robert J. Alexander +# +# Date: April 2, 1990 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# signed(s,n) -- Puts raw bits of characters of string s into an +# integer. The value is taken as signed. +# +# If large integers are supported, this routine will work for integers +# of arbitrary size. +# +# If large integers are not supported, the following are true: +# +# If the size of s is the same as or greater than the size of an +# integer in the Icon implementation, the result will be negative or +# positive depending on the value of the integer's sign bit. +# +# If the size of s is less than the size of an integer, the bytes are +# put into the low order part of the integer, with the remaining high +# order bytes filled with sign bits (the high order bit of the first +# character of the string). If the string is too large, the most +# significant bytes will be lost. +# +# This procedure is normally used for processing of binary data read +# from a file. +# + +procedure signed(s) + local i + i := if ord(s[1]) >= 128 then -1 else 0 + every i := ior(ord(!s),ishift(i,8)) + return i +end diff --git a/ipl/procs/sort.icn b/ipl/procs/sort.icn new file mode 100644 index 0000000..c73faa4 --- /dev/null +++ b/ipl/procs/sort.icn @@ -0,0 +1,170 @@ +########################################################################### +# +# File: sort.icn +# +# Subject: Procedures for sorting +# +# Authors: Bob Alexander, Richard L. Goerwitz, and Ralph E. Griswold +# +# Date: September 10, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# isort(x, p) +# customized sort in which procedure p is used for +# comparison. +# +# sortff(L, fields[]) +# like sortf(), except takes an unlimited number of field +# arguments. +# +# sortgen(T, m) +# generates sorted output in a manner specified by m: +# +# "k+" sort by key in ascending order +# "k-" sort by key in descending order +# "v+" sort by value in ascending order +# "v-" sort by value in descending order +# +# sortt(T, i) +# like sort(T, i) but produces a list of two-element records +# instead of a list of two-element lists. +# +############################################################################ +# +# Customizable sort procedure for inclusion in Icon programs. +# +# isort(x,keyproc,y) +# +# Argument x can be any Icon data type that is divisible into elements +# by the unary element generation (!) operator. The result is a list +# of the objects in sorted order. +# +# The default is to sort elements in their natural, Icon-defined order. +# However, an optional parameter (keyproc) allows a sort key to be +# derived from each element, rather than the default of using the +# element itself as the key. Keyproc can be a procedure provided by +# the caller, in which case the first argument to the key procedure is +# the item for which the key is to be computed, and the second argument +# is isort's argument y, passed unchanged. The keyproc must produce +# the extracted key. Alternatively, the keyproc argument can be an +# integer, in which case it specifies a subscript to be applied to each +# item to produce a key. Keyproc will be called once for each element +# of structure x. +# +############################################################################ + +procedure isort(x,keyproc,y) + local items,item,key,result + if y := integer(keyproc) then + keyproc := proc("[]",2) + else /keyproc := 1 + items := table() + every item := !x do { + key := keyproc(item,y) + (/items[key] := [item]) | put(items[key],item) + } + items := sort(items,3) + result := [] + while get(items) do every put(result,!get(items)) + return result +end + +# +# sortff: structure [x integer [x integer...]] -> structure +# (L, fields...) -> new_L +# +# Where L is any subscriptable structure, and fields are any +# number of integer subscripts in any desired order. Returns +# a copy of structure L with its elements sorted on fields[1], +# and, for those elements having an identical fields[1], sub- +# sorted on field[2], etc. +# + +procedure sortff(L, fields[]) #: sort on multiple fields + *L <= 1 & { return copy(L) } + return sortff_1(L, fields, 1, []) +end + +procedure sortff_1(L, fields, k, uniqueObject) + + local sortField, cachedKeyValue, i, startOfRun, thisKey + + sortField := fields[k] + L := sortf(L, sortField) # initial sort using fields[k] + # + # If more than one sort field is given, use each field successively + # as the current key, and, where members in L have the same value for + # this key, do a subsort using fields[k+1]. + # + if fields[k +:= 1] then { + # + # Set the equal-key-run pointer to the start of the list and + # save the value of the first key in the run. + # + startOfRun := 1 + cachedKeyValue := L[startOfRun][sortField] | uniqueObject + every i := 2 to *L do { + thisKey := L[i][sortField] | uniqueObject + if not (thisKey === cachedKeyValue) then { + # + # We have an element with a sort key different from the + # previous. If there's a run of more than one equal keys, + # sort the sublist. + # + if i - startOfRun > 1 then { + L := L[1:startOfRun] ||| + sortff_1(L[startOfRun:i], fields, k, uniqueObject) ||| + L[i:0] + } + # Reset the equal-key-run pointer to this key and cache. + startOfRun := i + cachedKeyValue := L[startOfRun][sortField] | uniqueObject + } + } + # + # Sort a final run if it exists. + # + if i - startOfRun > 0 then { + L := L[1:startOfRun] ||| + sortff_1(L[startOfRun:0], fields, k, uniqueObject) + } + } + + return L + +end + +procedure sortgen(T, m) #: generate by different sorting orders + local L + + L := sort(T, case m of { + "k+" | "k-": 1 + "v+" | "v-": 2 + }) + + case m of { + "k+" | "v+": suspend !L + "k-" | "v-": suspend L[*L to 1 by -1] + } + +end + +record element(key, value) + +procedure sortt(T, i) #: sort to produce list of records + local result, k + + if not(integer(i) = (1 | 2)) then runerr(205, i) + + result := [] + + every put(result, element(k := key(T), T[k])) + + return sortf(result, i) + +end diff --git a/ipl/procs/sortt.icn b/ipl/procs/sortt.icn new file mode 100644 index 0000000..a46b20e --- /dev/null +++ b/ipl/procs/sortt.icn @@ -0,0 +1,39 @@ +############################################################################ +# +# File: sortt.icn +# +# Subject: Procedure to sort table into records +# +# Author: Ralph E. Griswold +# +# Date: August 20, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This program sorts a table in the manner of sort(T, i) but produces a +# list of two-element records instead of a list of two-element lists +# +############################################################################ +# +# Requires: Version 9 +# +############################################################################ + +record element(key, value) + +procedure sortt(T, i) + local result, k + + if not(integer(i) = (1 | 2)) then runerr(205, i) + + result := [] + + every put(result, element(k := key(T), T[k])) + + return sortf(result, i) + +end diff --git a/ipl/procs/soundex.icn b/ipl/procs/soundex.icn new file mode 100644 index 0000000..012c7ee --- /dev/null +++ b/ipl/procs/soundex.icn @@ -0,0 +1,54 @@ +############################################################################ +# +# File: soundex.icn +# +# Subject: Procedures to produce Soundex code for name +# +# Author: Cheyenne Wills +# +# Date: July 14, 1989 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure produces a code for a name that tends to bring together +# variant spellings. See Donald E. Knuth, The Art of Computer Programming, +# Vol.3; Searching and Sorting, pp. 391-392. +# +############################################################################ + +procedure soundex(name) + local first, c, i + name := map(name,string(&lcase),string(&ucase)) # Convert to uppercase.. + first := name[1] + +# Retain the first letter of the name, and convert all +# occurrences of A,E,H,I,O,U,W,Y in other positions to "." +# +# Assign the following numbers to the remaining letters +# after the first: +# +# B,F,P,V => 1 L => 4 +# C,G,J,K,Q,S,X,Z => 2 M,N => 5 +# D,T => 3 R => 6 + + name := map(name,"ABCDEFGHIJKLMNOPQRSTUVWXYZ", + ".123.12..22455.12623.1.2.2") + +# If two or more letters with the same code were adjacent +# in the original name, omit all but the first + + every c := !"123456" do + while i := find(c||c,name) do + name[i+:2] := c + name[1] := first + +# Now delete our place holder ('.') + + while i := upto('.',name) do name[i] := "" + + return left(name,4,"0") +end diff --git a/ipl/procs/soundex1.icn b/ipl/procs/soundex1.icn new file mode 100644 index 0000000..18300a4 --- /dev/null +++ b/ipl/procs/soundex1.icn @@ -0,0 +1,85 @@ +############################################################################ +# +# File: soundex1.icn +# +# Subject: Procedures for Soundex algorithm +# +# Author: John David Stone +# +# Date: April 30, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# When names are communicated by telephone, they are often transcribed +# incorrectly. An organization that has to keep track of a lot of names has +# a need, therefore, for some system of representing or encoding a name that +# will mitigate the effects of transcription errors. One idea, originally +# proposed by Margaret K. Odell and Robert C. Russell, uses the following +# encoding system to try to bring together occurrences of the same surname, +# variously spelled: +# +# Encode each of the letters of the name according to the +# following equivalences: +# +# a, e, h, i, o, u, w, y -> * +# b, f, p, v -> 1 +# c, g, j, k, q, s, x, z -> 2 +# d, t -> 3 +# l -> 4 +# m, n -> 5 +# r -> 6 +# +# +# If any two adjacent letters have the same code, change the code for the +# second one to *. +# +# The Soundex representation consists of four characters: the initial letter +# of the name, and the first three digit (non-asterisk) codes corresponding +# to letters after the initial. If there are fewer than three such digit +# codes, use all that there are, and add zeroes at the end to make up the +# four-character representation. +# +############################################################################ + +procedure soundex(name) +local coded_name, new_name + + coded_name := encode(strip(name)) + new_name := name[1] + every pos := 2 to *coded_name do { + if coded_name[pos] ~== "*" then + new_name := new_name || coded_name[pos] + if *new_name = 4 then + break + } + return new_name || repl ("0", 4 - *new_name) +end + +procedure encode(name) + + name := map(name, &ucase, &lcase) + name := map(name, "aehiouwybfpvcgjkqsxzdtlmnr", + "********111122222222334556") + every pos := *name to 2 by -1 do + if name[pos - 1] == name[pos] then + name[pos] := "*" + return name +end + +procedure strip(name) +local result, ch + +static alphabet + +initial alphabet := string(&letters) + + result := "" + every ch := !name do + if find(ch, alphabet) then + result ||:= ch + return result +end diff --git a/ipl/procs/speedo.icn b/ipl/procs/speedo.icn new file mode 100644 index 0000000..15e7507 --- /dev/null +++ b/ipl/procs/speedo.icn @@ -0,0 +1,83 @@ +############################################################################ +# +# File: speedo.icn +# +# Subject: Procedure to indicate percentage of completion +# +# Author: Robert J. Alexander +# +# Date: March 25, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# speedo -- a "percentage complete" graphic indicator for +# command-line-oriented user interfaces. +# +# This is a general facility that can function for anything, and a +# specific implementation for input files. +# +# The general implementation consists of two procedures: +# +# SpeedoNew -- Starts a speedo +# SpeedoValue -- Sets a new value for the speedo (non-decreasing) +# +# See FileSpeedo for an example of using the general facility. +# +# FileSpeedo is especially for input files. Here is how to use it, by +# example: +# +# f := open("input_file") | stop("!!!") +# FileSpeedo(f,75,&errout) # Start a file speedo, specifying +# # length and output file +# while read(f) do { +# FileSpeedo(f) # Keep it updated while reading file +# ... +# } +# FileSpeedo() # Finish up +# +############################################################################ + +record SpeedoRec(max,length,file,lastOut,string) + +procedure SpeedoNew(max,length,file,str) + /length := 79 + /file := &errout + /str := "=" + write(file,"|",repl("-",length / *str * *str - 2),"|") + return SpeedoRec(max,length,file,0,str) +end + +procedure SpeedoValue(self,value) + local len + if /value then { + write(self.file) + return + } + len := self.length * value / self.max / *self.string + if len > self.lastOut then { + writes(self.file,repl(self.string,len - self.lastOut)) + self.lastOut := len + } + return self +end + +procedure FileSpeedo(file,length,outFile,str) + local savePos, fileSize + static speedo + if /file then { + SpeedoValue(speedo) + return + } + if \length then { + savePos := where(file) + seek(file,0) + fileSize := where(file) + seek(file,savePos) + return speedo := SpeedoNew(fileSize,length,outFile,str) + } + return SpeedoValue(speedo,where(file)) +end diff --git a/ipl/procs/spin.icn b/ipl/procs/spin.icn new file mode 100644 index 0000000..1556754 --- /dev/null +++ b/ipl/procs/spin.icn @@ -0,0 +1,35 @@ +############################################################################ +# +# File: spin.icn +# +# Subject: Procedure to spin cursor +# +# Author: Mark Otto +# +# Date: November 25, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Contributor: Ralph E. Griswold +# +############################################################################ +# +# This little procedure came from a discussion about how to produce +# a spinning cursor. The argument, if supplied, limits the number +# of cycles. +# +############################################################################ + +procedure spin(n) + + /n := 2 ^ 30 + n *:= 4 + + writes(" ") + every writes(!|["\b-","\b\\","\b|","\b/"]) \ n + +end diff --git a/ipl/procs/statemap.icn b/ipl/procs/statemap.icn new file mode 100644 index 0000000..90780d3 --- /dev/null +++ b/ipl/procs/statemap.icn @@ -0,0 +1,111 @@ +############################################################################ +# +# File: statemap.icn +# +# Subject: Procedure for table of states and abbreviations +# +# Author: Ralph E. Griswold +# +# Date: March 25, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure produces a "two-way" table to map state names (in +# the postal sense) to their postal abbreviations and vice-versa. +# +# The list is done in two parts with auxiliary procedures so that this +# procedure can be used with the default constant-table size for the +# translator and linker. +# +############################################################################ + +procedure statemap() + local state_list, state_map, i + + state_map := table() + + every state_list := __list1() | __list2() do + every i := 1 to *state_list - 1 by 2 do { + insert(state_map, state_list[i], state_list[i + 1]) + insert(state_map, state_list[i + 1], state_list[i]) + } + + return state_map + +end + +procedure __list1() + + return [ + "AK", "Alaska", + "AL", "Alabama", + "AR", "Arkansas", + "AS", "American Samoa", + "AZ", "Arizona", + "CA", "California", + "CO", "Colorado", + "CT", "Connecticut", + "DC", "District of Columbia", + "DE", "Delaware", + "FL", "Florida", + "FM", "Federated States of Micronesia", + "GA", "Georgia", + "GU", "Guam", + "HI", "Hawaii", + "IA", "Iowa", + "ID", "Idaho", + "IL", "Illinois", + "IN", "Indiana", + "KS", "Kansas", + "KY", "Kentucky", + "LA", "Louisiana", + "MA", "Massachusetts", + "MD", "Maryland", + "ME", "Maine", + "MH", "Marshall Islands", + "MI", "Michigan", + "MN", "Minnesota" + ] + +end + +procedure __list2() + + return [ + "MO", "Missouri", + "MP", "Northern Mariana Islands", + "MS", "Mississippi", + "MT", "Montana", + "NC", "North Carolina", + "ND", "North Dakota", + "NE", "Nebraska", + "NH", "New Hampshire", + "NJ", "New Jersey", + "NM", "New Mexico", + "NV", "Nevada", + "NY", "New York", + "OH", "Ohio", + "OK", "Oklahoma", + "OR", "Oregon", + "PA", "Pennsylvania", + "PR", "Puerto Rico", + "PW", "Palau", + "RI", "Rhode Island", + "SC", "South Carolina", + "SD", "South Dakota", + "TN", "Tennessee", + "TX", "Texas", + "UT", "Utah", + "VA", "Virginia", + "VT", "Vermont", + "WA", "Washington", + "WI", "Wisconsin", + "WV", "West Virginia", + "WY", "Wyoming" + ] + +end diff --git a/ipl/procs/step.icn b/ipl/procs/step.icn new file mode 100644 index 0000000..a6d8838 --- /dev/null +++ b/ipl/procs/step.icn @@ -0,0 +1,56 @@ +############################################################################ +# +# File: step.icn +# +# Subject: Procedure to generate in real increments +# +# Author: Ralph E. Griswold +# +# Date: April 6, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# step(r1, r2, r3) generates real values from r1 to r2 in increments of +# r3 (default 1.0). It is the real equivalent of i to j by k. +# If r2 is null, the sequence is infinite and is the real equivalent +# of seq(). +# +# Beware the usual problems of floating-point precision. +# +############################################################################ + +procedure step(r1, r2, r3) + + r1 := real(r1) | stop("*** invalid argument to step()") + \r2 := real(r2) | stop("*** invalid argument to step()") + /r3 := 1.0 + (r3 := real(r3)) ~= 0.0 | stop("*** invalid argument to step()") + r2 +:= 1E-6 # stab at avoiding underrun + + if \r2 then { # bounded sequence + if r3 > 0.0 then { + while r1 <= r2 do { + suspend r1 + r1 +:= r3 + } + } + else { + while r1 >= r2 do { + suspend r1 + r1 +:= r3 + } + } + } + + else { # bounded sequence + repeat { + suspend r1 + r1 +:= r3 + } + } + +end diff --git a/ipl/procs/str2toks.icn b/ipl/procs/str2toks.icn new file mode 100644 index 0000000..c795bf8 --- /dev/null +++ b/ipl/procs/str2toks.icn @@ -0,0 +1,89 @@ +############################################################################ +# +# File: str2toks.icn +# +# Subject: Procedures to convert string to tokens +# +# Author: Richard L. Goerwitz +# +# Date: March 3, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.2 +# +############################################################################ +# +# str2toks: cset x string x integer x integer -> strings +# (c, s, i, j) -> s1, s2, ... +# +# Suspends portions of s[i:j] delimited by characters in c. The +# usual defaults for s, i, and j apply, although str2toks is not +# meant as a primitive scanning function (note that it suspends +# strings, and not integer positions). +# +# Defaults: +# +# c ~(&letters ++ &digits) +# s &subject +# i &pos if s is defaulted, otherwise 1 +# j 0 +# +# Basically, this file is just a very simple piece of code wrapped up +# with some sensible defaults, and isolated in its own procedure. +# +############################################################################ +# +# Example: +# +# "hello, how are ya?" ? every write(str2toks()) +# +# The above expression would write to &output, on successive lines, +# the words "hello", "how", "are", and finally "ya" (skipping the +# punctuation). Naturally, the beginning and end of the line count +# as delimiters. +# +# Note that if i > 1 or j < *s+1 some tokens may end up appearing +# truncated. Normally, one should simply use the defaults for i and +# j - and for s as well when inside a scanning expression. +# +############################################################################ + +procedure str2toks(c, s, i, j) + + local token, default_val + + /c := ~(&letters ++ &digits) + + if /s := &subject + then default_val := &pos + else default_val := 1 + + if \i then { + if i < 1 then + i := *s + (i+1) + } + else i := default_val + + if \j then { + if j < 1 then + j := *s + (j+1) + } + else j := *s+1 + + s[i:j] ? { + tab(many(c)) + while token := tab(upto(c)) do { + suspend token + tab(many(c)) + } + suspend "" ~== tab(0) + } + +end + + diff --git a/ipl/procs/strings.icn b/ipl/procs/strings.icn new file mode 100644 index 0000000..26c4f28 --- /dev/null +++ b/ipl/procs/strings.icn @@ -0,0 +1,711 @@ +############################################################################ +# +# File: strings.icn +# +# Subject: Procedures for manipulating strings +# +# Author: Ralph E. Griswold +# +# Date: May 8, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures perform operations on strings. +# +# cat(s1, s2, ...) concatenates an arbitrary number of strings. +# +# charcnt(s, c) returns the number of instances of characters in +# c in s. +# +# collate(s1, s2) collates the characters of s1 and s2. For example, +# collate("abc", "def") +# produces "adbecf". +# +# comb(s, i) generates the combinations of characters from s +# taken i at a time. +# +# compress(s, c) compresses consecutive occurrences of charac- +# ters in c that occur in s; c defaults to &cset. +# +# coprefix(s1, s2, ...) +# produces the common prefix of its arguments: +# the longest initial substring shared by all, +# which may be the empty string. +# +# cosuffix(s1, s2, ...) +# produces the common suffix of its arguments: +# the longest trailing substring shared by all, +# which may be the empty string. +# +# csort(s) produces the characters of s in lexical order. +# +# decollate(s, i) produces a string consisting of every other +# character of s. If i is odd, the odd-numbered +# characters are selected, while if i is even, +# the even-numbered characters are selected. +# The default value of i is 1. +# +# deletec(s, c) deletes occurrences of characters in c from s. +# +# deletep(s, L) deletes all characters at positions specified in +# L. +# +# deletes(s1, s2) deletes occurrences of s2 in s1. +# +# diffcnt(s) returns count of the number of different +# characters in s. +# +# extend(s, n) replicates s to length n. +# +# fchars(s) returns characters of s in order of decreasing +# frequency +# +# interleave(s1, s2) interleaves characters s2 extended to the length +# of s1 with s1. +# +# ispal(s) succeeds and returns s if s is a palindrome +# +# maxlen(L, p) returns the length of the longest string in L. +# If p is given, it is applied to each string as +# as a "length" procedure. The default for p is +# proc("*", 1). +# +# meander(s, n) produces a "meandering" string that contains all +# n-tuples of characters of s. +# +# multicoll(L) returns the collation of the strings in L. +# +# ochars(s) produces the unique characters of s in the order +# that they first appear in s. +# +# odd_even(s) inserts values in a numerical string so that +# adjacent digits follow an odd-even pattern. +# +# palins(s, n) generates all the n-character palindromes from the +# characters in s. +# +# permutes(s) generates all the permutations of the string s. +# +# pretrim(s, c) trims characters from beginning of s. +# +# reflect(s1, i, s2) +# returns s1 concatenated s2 and the reversal of s1 +# to produce a palindroid; the values of i +# determine "end conditions" for the reversal: +# +# 0 pattern palindrome; the default +# 1 pattern palindrome with center duplicated +# 2 true palindrome with center not duplicated +# 3 true palindrome with center duplicated +# +# s2 defaults to the empty string, in which case the +# result is a full palindrome +# +# replace(s1, s2, s3) +# replaces all occurrences of s2 in s1 by s3; fails +# if s2 is null. +# +# replacem(s, ...) performs multiple replacements in the style of +# of replace(), where multiple argument pairs +# may be given, as in +# +# replacem(s, "a", "bc", "d", "cd") +# +# which replaced all "a"s by "bc"s and all +# "d"s by "cd"s. Replacements are performed +# one after another, not in parallel. +# +# replc(s, L) replicates each character of c by the amount +# given by the values in L. +# +# rotate(s, i) rotates s i characters to the left (negative i +# produces rotation to the right); the default +# value of i is 1. +# +# schars(s) produces the unique characters of s in lexical +# order. +# +# scramble(s) scrambles (shuffles) the characters of s randomly. +# +# selectp(s, L) selects characters of s that are at positions +# given in L. +# +# slugs(s, n, c) generates column-sized chunks (length <= n) +# of string s broken at spans of cset c. +# +# Defaults: n 80 +# c ' \t\r\n\v\f' +# +# Example: every write("> ", slugs(msg, 50)) +# +# starseq(s) sequence consisting of the closure of s +# starting with the empty string and continuing +# in lexical order as given in s +# +# strcnt(s1, s2) produces a count of the number of non-overlapping +# times s1 occurs in s2; fails is s1 is null +# +# substrings(s, i, j) +# generates all the substrings of s with lengths +# from i to j, inclusive; i defaults to 1, j +# to *s +# +# transpose(s1, s2, s3) +# transposes s1 according to label s2 and +# transposition s3. +# +# words(s, c) generates the "words" from the string s that +# are separated by characters from the cset +# c, which defaults to ' \t\r\n\v\f'. +# +############################################################################ +# +# Links: lists +# +############################################################################ + +link lists + +procedure cat(args[]) #: concatenate strings + local result + + result := "" + + every result ||:= !args + + return result + +end + +procedure charcnt(s, c) #: character count + local count + + count := 0 + + s ? { + while tab(upto(c)) do + count +:= *tab(many(c)) + } + + return count + +end + +procedure collate(s1, s2) #: string collation + local length, ltemp, rtemp + static llabels, rlabels, clabels, blabels, half + + initial { + llabels := "ab" + rlabels := "cd" + blabels := llabels || rlabels + clabels := "acbd" + half := 2 + ltemp := left(&cset, *&cset / 2) + rtemp := right(&cset, *&cset / 2) + clabels := collate(ltemp, rtemp) + llabels := ltemp + rlabels := rtemp + blabels := string(&cset) + half := *llabels + } + + length := *s1 + if length <= half then + return map(left(clabels, 2 * length), left(llabels, length) || + left(rlabels, length), s1 || s2) + else return map(clabels, blabels, left(s1, half) || left(s2, half)) || + collate(right(s1, length - half), right(s2, length - half)) + +end + +procedure comb(s, i) #: character combinations + local j + + if i < 1 then fail + suspend if i = 1 then !s + else s[j := 1 to *s - i + 1] || comb(s[j + 1:0], i - 1) + +end + +procedure compress(s, c) #: character compression + local result, s1 + + /c := &cset + + result := "" + + s ? { + while result ||:= tab(upto(c)) do { + result ||:= (s1 := move(1)) + tab(many(s1)) + } + return result || tab(0) + } +end + +procedure coprefix(args[]) #: find common prefix of strings + local s, t, i + + s := get(args) | fail + every t := !args do { + every i := seq(1) do + if not (s[i] == t[i]) then break + s := s[1+:(i-1)] + } + return s +end + +procedure cosuffix(args[]) #: find common suffix of strings + local s, t, i + + s := get(args) | fail + every t := !args do { + every i := seq(-1, -1) do + if not (s[i] == t[i]) then break + s := s[i+1:0] + } + return s +end + +procedure csort(s) #: lexically ordered characters + local c, s1 + + s1 := "" + + every c := !cset(s) do + every find(c, s) do + s1 ||:= c + + return s1 + +end + +# decollate s according to even or odd i +# +procedure decollate(s, i) #: string decollation + local ssize + static dsize, image, object + + initial { + image := collate(left(&cset, *&cset / 2), left(&cset, *&cset / 2)) + object := left(&cset, *&cset / 2) + dsize := *image + } + + /i := 1 + + i %:= 2 + ssize := *s + + if ssize + i <= dsize then + return map(object[1+:(ssize + i) / 2], image[(i + 1)+:ssize], s) + else return map(object[1+:(dsize - 2) / 2], image[(i + 1)+:dsize - 2], + s[1+:(dsize - 2)]) || decollate(s[dsize - 1:0], i) + +end + +procedure deletec(s, c) #: delete characters + local result + + result := "" + + s ? { + while result ||:= tab(upto(c)) do + tab(many(c)) + return result ||:= tab(0) + } + +end + +procedure deletep(s, L) + + L := sort(L) + + while s[pull(L)] := "" + + return s + +end + +procedure deletes(s1, s2) #: delete string + local result, i + + result := "" + i := *s2 + + s1 ? { + while result ||:= tab(find(s2)) do + move(i) + return result ||:= tab(0) + } + +end + +procedure diffcnt(s) #: number of different characters + + return *cset(s) + +end + +procedure extend(s, n) #: extend string + local i + + if *s = 0 then fail + + i := n / *s + if n % *s > 0 then i +:= 1 + + return left(repl(s, i), n) + +end + +procedure fchars(s) #: characters in order of frequency + local counts, clist, bins, blist, result + + counts := table(0) + every counts[!s] +:= 1 + clist := sort(counts, 4) + + bins := table('') + while bins[pull(clist)] ++:= pull(clist) + blist := sort(bins, 3) + + result := "" + while result ||:= pull(blist) do + pull(blist) + + return result + +end + +procedure interleave(s1, s2) #: interleave strings + + return collate(s1, extend(s2, *s1)) | fail + +end + +procedure ispal(s) #: test for palindrome + + if s == reverse(s) then return s else fail + +end + +procedure maxlen(L, p) #: maximum string length + local i + + if *L = 0 then fail + + /p := proc("*", 1) + + i := 0 + + every i <:= p(!L) + + return i + +end + +procedure meander(alpha, n) #: meandering strings + local result, trial, t, i, c + + i := *alpha + t := n - 1 + result := repl(alpha[1], t) # base string + + while c := alpha[i] do { # try a character + result ? { # get the potential n-tuple + tab(-t) + trial := tab(0) || c + } + if result ? find(trial) then # duplicate, work back + i -:= 1 + else { + result ||:= c # add it + i := *alpha # and start from end again + } + } + + return result[n:0] + +end + +procedure multicoll(L) #: collate strings in list + local result, i, j + + result := "" + + every i := 1 to *L[1] do # no other longer if legal + every j := 1 to *L do + result ||:= L[j][i] + + return result + +end + +procedure ochars(w) #: first appearance unique characters + local out, c + + out := "" + + every c := !w do + if not find(c, out) then + out ||:= c + + return out + +end + +procedure odd_even(s) #: odd-even numerical string + local result, i, j + + every i := integer(!s) do { + if /result then result := i + else if (i % 2) = (j % 2) then result ||:= (j + 1) || i + else result ||:= i + j := i + } + + return result + +end + +procedure palins(s, n) #: palindromes + local c, lpart, mpart, rpart, h, p + + if n = 1 then suspend !s + else if n = 2 then + every c := !s do suspend c || c + else if n % 2 = 0 then { # even + h := (n - 2) / 2 + every p := palins(s, n - 2) do { + p ? { + lpart := move(h) + rpart := tab(0) + } + every c := !s do { + mpart := c || c + suspend lpart || mpart || rpart + } + } + } + else { # odd + h := (n - 1) / 2 + every p := palins(s, n - 1) do { + p ? { + lpart := move(h) + rpart := tab(0) + } + every suspend lpart || !s || rpart + } + } + +end + +procedure permutes(s) #: generate string permutations + local i + + if *s = 0 then return "" + suspend s[i := 1 to *s] || permutes(s[1:i] || s[i+1:0]) + +end + +procedure pretrim(s, c) #: pre-trim string + + /c := ' ' + + s ? { + tab(many(c)) + return tab(0) + } + +end + +procedure reflect(s1, i, s2) #: string reflection + + /i :=0 + /s2 := "" + + return s1 || s2 || reverse( + case i of { + 0: s1[2:-1] # pattern palindrome + 1: s1[2:0] # pattern palindrome with first character at end + 2: s1[1:-1] # true palindrome with center character unduplicated + 3: s1 # true palindrome with center character duplicated + } + ) + +end + +procedure replace(s1, s2, s3) #: string replacement + local result, i + + result := "" + i := *s2 + if i = 0 then fail # would loop on empty string + + s1 ? { + while result ||:= tab(find(s2)) do { + result ||:= s3 + move(i) + } + return result || tab(0) + } + +end + +procedure replacem(s, pairs[]) #: multiple string replacement + + while s := replace(s, get(pairs), get(pairs)) + + return s + +end +procedure replc(s, L) #: replicate characters + local result + + result := "" + + every result ||:= repl(!s, get(L)) + + return result + +end + +procedure rotate(s, i) #: string rotation + + if s == "" then return s + /i := 1 + if i = 0 then return s + else if i < 0 then i +:= *s + i %:= *s + + return s[(i + 1):0] || s[1:(i + 1)] + +end + +procedure schars(s) #: lexical unique characters + + return string(cset(s)) + +end + +procedure scramble(s) #: scramble string + local i + + s := string(s) | fail + + every i := *s to 2 by -1 do + s[?i] :=: s[i] + + return s + +end + +procedure selectp(s, L) #: select characters + local result + + result := "" + + every result ||:= s[!L] + + return result + +end + +procedure slugs(s, n, c) #: generate s in chunks of size <= n + local i, t + + (/n := 80) | (n := 0 < integer(n)) | runerr(101, n) + /c := ' \t\r\n\v\f' + + n +:= 1 + while *s > 0 do s ? { + if *s <= n then + return trim(s, c) + if tab(i := (n >= upto(c))) then { + tab(many(c)) + while tab(i := (n >= upto(c))) do { + tab(many(c)) + } + suspend .&subject[1:i] + } + else { + t := tab(n | 0) + suspend t + } + s := tab(0) + } + fail +end + +procedure starseq(s) #: closure sequence + + /s := "" + + suspend "" | (starseq(s) || !s) + +end + +procedure strcnt(s1, s2) #: substring count + local j, i + + if *s1 = 0 then fail # null string would loop + + j := 0 + i := *s1 + + s2 ? { + while tab(find(s1)) do { + j +:= 1 + move(i) + } + return j + } + +end + +procedure substrings(s, i, j) #: generate substrings + + /i := 1 + /j := *s + + s ? { + every tab(1 to *s) do + suspend move(i to j) + } + +end + +procedure transpose(s1, s2, s3) #: transpose characters + local n, result + + n := *s2 + result := "" + + s1 ? { + while result ||:= map(s3, s2, move(n)) + return result ||:= tab(0) + } + +end + +procedure words(s, c) #: generate words from string + + /c := ' \t\r\n\v\f' + + s ? { + tab(many(c)) + while not pos(0) do { + suspend tab(upto(c) | 0) \ 1 + tab(many(c)) + } + } + + fail + +end diff --git a/ipl/procs/strip.icn b/ipl/procs/strip.icn new file mode 100644 index 0000000..0234074 --- /dev/null +++ b/ipl/procs/strip.icn @@ -0,0 +1,41 @@ +############################################################################ +# +# File: strip.icn +# +# Subject: Procedure to strip characters from a string +# +# Author: Richard L. Goerwitz +# +# Date: June 3, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.1 +# +############################################################################ +# +# strip(s,c) - strip characters c from string s +# +############################################################################ + +procedure strip(s,c) + + # Return string s stripped of characters c. Succeed whether + # any characters c were found in s or not. + + local s2 + + s2 := "" + s ? { + while s2 ||:= tab(upto(c)) + do tab(many(c)) + s2 ||:= tab(0) + } + + return s2 + +end diff --git a/ipl/procs/stripcom.icn b/ipl/procs/stripcom.icn new file mode 100644 index 0000000..a9fa89f --- /dev/null +++ b/ipl/procs/stripcom.icn @@ -0,0 +1,71 @@ +############################################################################ +# +# File: stripcom.icn +# +# Subject: Procedures to strip comments from Icon line +# +# Author: Richard L. Goerwitz +# +# Date: March 3, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.5 +# +############################################################################ +# +# Strip commented-out portion of a line of Icon code. Fails on lines +# which, either stripped or otherwise, come out as an empty string. +# +############################################################################ +# +# BUGS: Can't handle lines ending in an underscore as part of a +# broken string literal, since stripcom is not intended to be used +# on sequentially read files. It simply removes comments from indi- +# vidual lines. +# +############################################################################ + + +# To preserve parallelism between file and procedure names. +procedure stripcom(s) + return strip_comments(s) +end + + +# The original name - +procedure strip_comments(s) + + 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 diff --git a/ipl/procs/stripunb.icn b/ipl/procs/stripunb.icn new file mode 100644 index 0000000..21fe89a --- /dev/null +++ b/ipl/procs/stripunb.icn @@ -0,0 +1,134 @@ +############################################################################ +# +# File: stripunb.icn +# +# Subject: Procedures to strip unbalanced material +# +# Author: Richard L. Goerwitz +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Version: 1.7 +# +############################################################################ +# +# This routine strips material from a line which is unbalanced with +# respect to the characters defined in arguments 1 and 2 (unbalanced +# being defined as bal() defines it, except that characters preceded +# by a backslash are counted as regular characters, and are not taken +# into account by the balancing algorithm). +# +# One little bit of weirdness I added in is a table argument. Put +# simply, if you call stripunb() as follows, +# +# stripunb('<','>',s,&null,&null,t) +# +# and if t is a table having the form, +# +# key: "bold" value: outstr("\e[2m", "\e1m") +# key: "underline" value: outstr("\e[4m", "\e1m") +# etc. +# +# then every instance of "<bold>" in string s will be mapped to +# "\e2m," and every instance of "</bold>" will be mapped to "\e[1m." +# Values in table t must be records of type output(on, off). When +# "</>" is encountered, stripunb will output the .off value for the +# preceding .on string encountered. +# +############################################################################ +# +# Links: scan +# +############################################################################ + +link scan + +global last_k +record outstr(on, off) + + +procedure stripunb(c1,c2,s,i,j,t) + + # NB: Stripunb() returns a string - not an integer (like find, + # upto). + + local lookinfor, bothcs, s2, k, new_s, c, compl + #global last_k + initial last_k := list() + + /c1 := '<' + /c2 := '>' + bothcs := c1 ++ c2 + lookinfor := c1 ++ '\\' + c := &cset -- c1 -- c2 + + /s := &subject + if \i then { + if i < 1 then + i := *s + (i+1) + } + else i := \&pos | 1 + if \j then { + if j < 1 then + j := *s + (j+1) + } + else j := *s + 1 + + s2 := "" + s ? { + while s2 ||:= tab(upto(lookinfor)) do { + if ="\\" then { + if not any(bothcs) then + s2 ||:= "\\" + &pos+1 > j & (return s2) + s2 ||:= move(1) + next + } + else { + &pos > j & (return s2) + any(c1) | + stop("stripunb: Unbalanced string, pos(",&pos,").\n",s) + if not (k := tab(&pos <= slashbal(c,c1,c2,&subject))) + then { + # If the last char on the line is the right-delim... + if (.&subject[&pos:0]||" ") ? slashbal(c,c1,c2) + # ...then, naturally, the rest of the line is the tag. + then k := tab(0) + else { + # BUT, if it's not the right-delim, then we have a + # tag split by a line break. Blasted things. + return stripunb(c1,c2,&subject||read(&input), + *.&subject,,t) | + # Can't find the right delimiter. Parsing error. + stop("stripunb: Incomplete tag\n",s[1:80] | s) + } + } + # T is the maptable. + if \t then { + k ?:= 2(tab(any(c1)), tab(upto(c2)), move(1), pos(0)) + if k ?:= (="/", tab(0)) then { + compl:= pop(last_k) | stop("Incomplete tag, ",&subject) + if k == "" + then k := compl + else k == compl | stop("Incorrectly paired tag,/tag.") + s2 ||:= \(\t[k]).off + } + else { + s2 ||:= \(\t[k]).on + push(last_k, k) + } + } + } + } + s2 ||:= tab(0) + } + + return s2 + +end diff --git a/ipl/procs/tab2list.icn b/ipl/procs/tab2list.icn new file mode 100644 index 0000000..6d9a9df --- /dev/null +++ b/ipl/procs/tab2list.icn @@ -0,0 +1,42 @@ +############################################################################ +# +# File: tab2list.icn +# +# Subject: Procedure to put tab-separated strings in list +# +# Author: Ralph E. Griswold +# +# Date: January 3, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure to takes tab-separated strings and inserts them +# into a list. +# +# Vertical tabs in strings are converted to carriage returns. +# +# (Works for lists too.) +# +############################################################################ +# +# See also: list2tab.icn, tab2rec.icn, rec2tab.icn +# +############################################################################ + +procedure tab2list(s) + local L + + L := [] + + s ? { + while put(L, map(tab(upto('\t') | 0), "\v", "\n")) do + move(1) | break + } + + return L + +end diff --git a/ipl/procs/tab2rec.icn b/ipl/procs/tab2rec.icn new file mode 100644 index 0000000..9a59e93 --- /dev/null +++ b/ipl/procs/tab2rec.icn @@ -0,0 +1,38 @@ +############################################################################ +# +# File: tab2rec.icn +# +# Subject: Procedure to put tab-separated strings in records +# +# Author: Ralph E. Griswold +# +# Date: July 6, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure to takes tab-separated strings and inserts them +# into fields of a record. +# +# Vertical tabs in strings are converted to carriage returns. +# +# (Works for lists too.) +# +############################################################################ + +procedure tab2rec(s, rec) + local i + + i := 0 + + s ? { + while rec[i +:= 1] := map(tab(upto('\t') | 0), "\v", "\n") do + move(1) | break + } + + return + +end diff --git a/ipl/procs/tables.icn b/ipl/procs/tables.icn new file mode 100644 index 0000000..f4eabd3 --- /dev/null +++ b/ipl/procs/tables.icn @@ -0,0 +1,178 @@ +############################################################################ +# +# File: tables.icn +# +# Subject: Procedures for table manipulation +# +# Author: Ralph E. Griswold +# +# Date: August 20, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Contributor: Alan Beale +# +############################################################################ +# +# keylist(T) produces list of keys in table T. +# +# kvallist(T) produces values in T ordered by sorted order +# of keys. +# +# tbleq(T1, T2) tests equivalences of tables T1 amd T2. +# +# tblunion(T1, T2) approximates T1 ++ T2. +# +# tblinter(T1, T2) approximates T1 ** T2. +# +# tbldiff(T1, T2) approximates T1 -- T2. +# +# tblinvrt(T) produces a table whose keys are T's values and +# whose values are T's keys. +# +# tbldflt(T) produces the default value for T. +# +# twt(T) produces a two-way table based on T. +# +# vallist(T) produces list of values in table T. +# +############################################################################ +# +# For the operations on tables that mimic set operations, the +# correspondences are only approximate and do not have the mathematical +# properties of the corresponding operations on sets. For example, table +# "union" is not symmetric or transitive. +# +# Where there is potential asymmetry, the procedures "favor" their +# first argument. +# +# All the procedures that return tables return new tables and do not +# modify their arguments. +# +############################################################################ + +procedure tblunion(T1, T2) #: table union + local T3, x + + T3 := copy(T1) + + every x := key(T2) do + insert(T3, x, T2[x]) + + return T3 + +end + +procedure tblinter(T1, T2) #: table intersection + local T3, x + + T3 := table(tbldflt(T1)) + + every x := key(T1) do + if member(T2, x) then insert(T3, x, T1[x]) + + return T3 + +end + +procedure tbldiff(T1, T2) #: table difference + local T3, x + + T3 := copy(T1) + + every x := key(T2) do + delete(T3, x) + + return T3 + +end + +procedure tblinvrt(T) #: table inversion + local T1, x + + T1 := table(tbldflt(T)) + + every x := key(T) do + insert(T1, T[x], x) + + return T1 + +end + +procedure tbldflt(T) #: table default + static probe + + initial probe := [] # only need one + + return T[probe] + +end + +procedure twt(T) #: two-way table + local T1, x + + T1 := copy(T) + + every x := key(T) do + insert(T1, T[x], x) + + return T1 + +end + +procedure keylist(tbl) #: list of keys in table + local lst + + lst := [] + every put(lst, key(tbl)) + return sort(lst) + +end + +procedure kvallist(T) + local result + + result := [] + + every put(result, T[!keylist(T)]) + + return result + +end + +procedure tbleq(tbl1, tbl2) #: table equivalence + local x + static prod + + initial prod := [] + + if *tbl1 ~= *tbl2 then fail + if tbl1[prod] ~=== tbl2[prod] then fail + else every x := key(tbl1) do + if not(member(tbl2, x)) | + (tbl2[x] ~=== tbl1[x]) then fail + return tbl2 + +end + +procedure vallist(tbl) #: list of table values + local list1 + + list1 := [] + every put(list1, !tbl) + return sort(list1) + +end + +procedure valset(tbl) #: set of table values + local set1 + + set1 := set() + every insert(set1, !tbl) + return set1 + +end diff --git a/ipl/procs/tclass.icn b/ipl/procs/tclass.icn new file mode 100644 index 0000000..6c602b2 --- /dev/null +++ b/ipl/procs/tclass.icn @@ -0,0 +1,32 @@ +############################################################################ +# +# File: tclass.icn +# +# Subject: Procedure to classify values as atomic or composite +# +# Author: Ralph E. Griswold +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# tclass(x) returns "atomic" or "composite" depending on the type of x. +# +############################################################################ + +procedure tclass(x) + + return case type(x) of { + "null" | + "integer" | + "real" | + "string" | + "cset": "atomic" + default: "composite" + } + +end diff --git a/ipl/procs/title.icn b/ipl/procs/title.icn new file mode 100644 index 0000000..5aa61ba --- /dev/null +++ b/ipl/procs/title.icn @@ -0,0 +1,44 @@ +############################################################################ +# +# File: title.icn +# +# Subject: Procedure to produce title portion of name +# +# Author: Ralph E. Griswold +# +# Date: March 25, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure produces the "title" of a name, as "Mr." from +# "Mr. John Doe". +# +# The process is imperfect. +# +############################################################################ +# +# Links: titleset +# +############################################################################ + +link titleset + +procedure title(name) + local result + static titles + + initial titles := titleset() + + result := "" + + name ? { + while result ||:= =!titles || " " do + tab(many(' \t')) + return result ? tab(-1 | 0) + } + +end diff --git a/ipl/procs/titleset.icn b/ipl/procs/titleset.icn new file mode 100644 index 0000000..d69c1fc --- /dev/null +++ b/ipl/procs/titleset.icn @@ -0,0 +1,36 @@ +############################################################################ +# +# File: titleset.icn +# +# Subject: Procedure to produce set of titles +# +# Author: Ralph E. Griswold +# +# Date: September 2, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure produces a set of strings that commonly appear as +# titles in names. This set is (necessarily) incomplete. +# +############################################################################ + +procedure titleset() + local titles + + titles := set() + + every insert(titles, + "Mr." | "Mrs." | "Ms." | "Dr." | "Prof." | + "Mister" | "Miss" | "Doctor" | "Professor" | "Herr" | + "-Phys." | "Dipl.-Phys." | "Dipl." | "Ing." | + "Sgt." | "Tsgt." | "Col." | "Lt" | "Capt." | "Gen." | "Adm." + ) + + return titles + +end diff --git a/ipl/procs/tokgen.icn b/ipl/procs/tokgen.icn new file mode 100644 index 0000000..aa92811 --- /dev/null +++ b/ipl/procs/tokgen.icn @@ -0,0 +1,376 @@ +############################################################################ +# +# File: tokgen.icn +# +# Subject: Procedures for token counting +# +# Author: Ralph E. Griswold +# +# Date: May 23, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures are for use with code produced by a meta-translator. +# The result of linking these procedures with a program +# translated by standard the meta-translator and executing the +# result is a tabulation of the tokens in the program. +# +############################################################################ +# +# Bug: The invocable declaration is not handled properly. "invocable all" +# will get by, but some other forms produce syntax errors. The +# problem is in the meta-translator itself, not in this +# program. +# +############################################################################ +# +# Links: showtbl +# +############################################################################ + +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 +global all # kludge -- invocable is not handled properly + +procedure main() + local names, tables, i, total, count + + total := 0 # total number of tokens + + # 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"] + + # Call the procedure corresponding to the target program. + # It adds the token counts to the tables. + + Mp() + + every i := 1 to *names do { + count := showtbl(names[i],tables[i])[1] + total +:= count + write("\n", right(count, 8), " total") + } + write("\nTotal tokens: ", total) + +end + +procedure Alt(e1, e2) # e1 | e2 + controls["e1 | e2"] +:= 1 + return +end + +procedure Apply(e1, e2) # e1 ! e2 + binops["e1 ! e2"] +:= 1 + return +end + +procedure Arg(s) + return s +end + +procedure Asgnop(op, e1, e2) # e1 op e2 + binops["e1 " || op || " e2"] +:= 1 + return +end + +procedure Augscan(e1, e2) # e1 ?:= e2 + controls["e1 ?:= e2"] +:= 1 + return +end + +procedure Bamper(e1, e2) # e1 & e2 + binops["e1 & e2"] +:= 1 + return +end + +procedure Binop(s) + binops["e1 " || s || " e2"] +:= 1 + return +end + +procedure Body(s[]) # procedure body + return +end + +procedure Break(e) # break e + controls["break e"] +:= 1 + return +end + +procedure Case(e, clist) # case e of { caselist } + controls["case"] +:= 1 + return +end + +procedure Cclause(e1, e2) # e1 : e2 + controls["case selector"] +:= 1 + return +end + +procedure Clist(e1, e2) # e1 ; e2 in case list + return +end + +procedure Clit(s) + clits[image(s)] +:= 1 + return +end + +procedure Compound(es[]) # { e1; e2; ... } + every controls["{...}"] +:= 1 + return +end + +procedure Create(e) # create e + controls["create e"] +:= 1 + return +end + +procedure Default(e) # default: e + controls["default"] +:= 1 + return +end + +procedure End() # end + return +end + +procedure Every(e) # every e + controls["every e"] +:= 1 + return +end + +procedure EveryDo(e1, e2) # every e1 do e2 + controls["every e1 do e2"] +:= 1 + return +end + +procedure Fail() # fail + controls["fail"] +:= 1 + return +end + +procedure Field(e1, e2) # e . f + binops["e1 . e2"] +:= 1 + fldref[e2] +:= 1 + return +end + +procedure Global(vs[]) # global v1, v2, ... + every globals[!vs] +:= 1 + declarations["global"] +:= *vs # each name counts as a declaration + return +end + +procedure If(e1, e2) # if e1 then e2 + controls["if e1 then e2"] +:= 1 + return +end + +procedure IfElse(e1, e2, e3) # if e1 then e2 else e3 + controls["if e1 then e2 else e3"] +:= 1 + return +end + +procedure Ilit(s) + ilits[s] +:= 1 + return +end + +procedure Initial(s) # initial e + controls["initial"] +:= 1 + return +end + +procedure Invocable(es[]) # invocable ... (problem) + declarations["invocable"] +:= 1 + return +end + +procedure Invoke(e0, es[]) # e0(e1, e2, ...) + others["e(...)"] +:= 1 + return +end + +procedure Key(s) + keys["&" || s] +:= 1 + return +end + +procedure Limit(e1, e2) # e1 \ e2 + controls["e1 \\ e2"] +:= 1 + return +end + +procedure Link(vs[]) # link "v1, v2, ..." + every files[!vs] +:= 1 + declarations["link"] +:= *vs # each file counts as a declaration + return +end + +procedure List(es[]) # [e1, e2, ... ] + others["[...]"] +:= 1 + return +end + +procedure Local(vs[]) # local v1, v2, ... + every locals[!vs] +:= 1 + declarations["local"] +:= *vs # each name counts as a declaration + return +end + +procedure Next() # next + controls["next"] +:= 1 + return +end + +procedure Not(e) # not e + controls["not e"] +:= 1 + return +end + +procedure Null() # &null + return +end + +procedure Paren(es[]) # (e1, e2, ... ) + if *es > 1 then others["(...)"] +:= 1 + return +end + +procedure Pdco(e0, es[]) # e0{e1, e2, ... } + others["e{...}"] +:= 1 + return +end + +procedure Proc(s, es[]) # procedure s(v1, v2, ...) + local p + + every parms[\!es] +:= 1 do + declarations["procedure"] +:= 1 + return +end + +procedure Record(s, es[]) # record s(v1, v2, ...) + every fields[\!es] +:= 1 + declarations["record"] +:= 1 + return +end + +procedure Repeat(e) # repeat e + controls["repeat e"] +:= 1 + return +end + +procedure Return(e) # return e + controls["return e"] +:= 1 + return +end + +procedure Rlit(s) + rlits[s] +:= 1 + return +end + +procedure Scan(e1, e2) # e1 ? e2 + controls["e1 ? e2"] +:= 1 + return +end + +procedure Section(op, e1, e2, e3) # e1[e2 op e3] + others["e1[e2" || op || "e3]"] +:= 1 + return +end + +procedure Slit(s) + slits[image(s)] +:= 1 + return +end + +procedure Static(ev[]) # static v1, v2, .. + every statics[!ev] +:= 1 + declarations["static"] +:= *ev # each name counts as a declaration + return +end + +procedure Subscript(e1, e2) # e1[e2] + binops["e1[e2]"] +:= 1 + return +end + +procedure Suspend(e) # suspend e + controls["suspend e"] +:= 1 + return +end + +procedure SuspendDo(e1, e2) # suspend e1 do e2 + controls["suspend e1 do e2"] +:= 1 + return +end + +procedure To(e1, e2) # e1 to e2 + others["e1 to e2"] +:= 1 + return +end + +procedure ToBy(e1, e2, e3) # e1 to e2 by e3 + others["e1 to e2 by e3"] +:= 1 + return +end + +procedure Repalt(e) # |e + controls["|e"] +:= 1 + return +end + +procedure Unop(s) # op e (op may be compound) + every unops[!s || "e"] +:= 1 + return +end + +procedure Until(e) # until e + controls["until e"] +:= 1 + return +end + +procedure UntilDo(e1, e2) # until e1 do e2 + controls["until e1 do e2"] +:= 1 + return +end + +procedure Var(s) + vars[s] +:= 1 + return +end + +procedure While(e) # while e + controls["while e"] +:= 1 + return +end + +procedure WhileDo(e1, e2) # while e1 do e2 + controls["while e1 do e2"] +:= 1 + return +end diff --git a/ipl/procs/trees.icn b/ipl/procs/trees.icn new file mode 100644 index 0000000..c76c069 --- /dev/null +++ b/ipl/procs/trees.icn @@ -0,0 +1,106 @@ +############################################################################ +# +# File: trees.icn +# +# Subject: Procedures for manipulating trees and dags +# +# Author: Ralph E. Griswold +# +# Date: December 27, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# depth(t) compute maximum depth of tree t +# +# ldag(s) construct a dag from the string s +# +# ltree(s) construct a tree from the string s +# +# stree(t) construct a string from the tree t +# +# tcopy(t) copy tree t +# +# teq(t1,t2) compare trees t1 and t2 +# +# visit(t) visit, in preorder, the nodes of the tree t +# +############################################################################ + +procedure depth(ltree) #: depth of tree + local count + + count := 0 + every count <:= 1 + depth(ltree[2 to *ltree]) + return count + +end + +procedure ldag(stree,done) #: construct dag from string + local L + + /done := table() + if L := \done[stree] then return L + stree ? + if L := [tab(upto('('))] then { + move(1) + while put(L,ldag(tab(bal(',)')),done)) do + move(1) + } + else L := [tab(0)] + return done[stree] := L + +end + +procedure ltree(stree) #: construct tree from string + local L + + stree ? + if L := [tab(upto('('))] then { + move(1) + while put(L,ltree(tab(bal(',)')))) do + move(1) + } + else L := [tab(0)] + return L + +end + +procedure stree(ltree) #: construct string from tree + local s + + if *ltree = 1 then return ltree[1] + s := ltree[1] || "(" + every s ||:= stree(ltree[2 to *ltree]) || "," + return s[1:-1] || ")" + +end + +procedure tcopy(ltree) #: tree copy + local L + + L := [ltree[1]] + every put(L,tcopy(ltree[2 to *ltree])) + return L + +end + +procedure teq(L1,L2) #: tree equivalence + local i + + if *L1 ~= *L2 then fail + if L1[1] ~== L2[1] then fail + every i := 2 to *L1 do + if not teq(L1[i],L2[i]) then fail + return L2 + +end + +procedure visit(ltree) #: visit nodes of tree + + suspend ltree | visit(ltree[2 to *ltree]) + +end diff --git a/ipl/procs/tuple.icn b/ipl/procs/tuple.icn new file mode 100644 index 0000000..fba830f --- /dev/null +++ b/ipl/procs/tuple.icn @@ -0,0 +1,67 @@ +############################################################################ +# +# File: tuple.icn +# +# Subject: Procedure to process n-tuples +# +# Author: William H. Mitchell +# +# Date: June 10, 1988 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure implements a "tuple" feature that produces the effect +# of multiple keys. A tuple is created by an expression of the +# form +# +# tuple([exrp1, expr2, ..., exprn]) +# +# The result can be used in a case expression or as a table subscript. +# Lookup is successful provided the values of expr1, expr2, ..., exprn +# are the same (even if the lists containing them are not). For example, +# consider selecting an operation based on the types of two operands. The +# expression +# +# case [type(op1), type(op2)] of { +# ["integer", "integer"]: op1 + op2 +# ["string", "integer"] : op1 || "+" || op2 +# ["integer", "string"] : op1 || "+" || op2 +# ["string", "string"] : op1 || "+" || op2 +# } +# +# does not work, because the comparison in the case clauses compares lists +# values, which cannot be the same as control expression, because the lists +# are different, even though their contents are the same. With tuples, +# however, the comparison succeeds, as in +# +# case tuple([type(op1), type(op2)]) of { +# tuple(["integer", "integer"]): op1 + op2 +# tuple(["string", "integer"]) : op1 || "+" || op2 +# tuple(["integer", "string"]) : op1 || "+" || op2 +# tuple(["string", "string"]) : op1 || "+" || op2 +# } +# +############################################################################ + +procedure tuple(tl) + local tb, i, e, le + + static tuptab + initial tuptab := table() # create the root node + + /tuptab[*tl] := table() # if there is no table for this size, make one + tb := tuptab[*tl] # go to tuple for size of table + i := 0 # assign default value to i + every i := 1 to *tl - 1 do { # iterate though all but last value + e := tl[i] # ith value in tuple + /tb[e] := table() # if it is not in the table, make a new one + tb := tb[e] # go to table for that value + } + le := tl[i + 1] # last value in tuple + /tb[le] := copy(tl) # if it is new, entr a copy of the list + return tb[le] # return the copy; it is unique +end diff --git a/ipl/procs/typecode.icn b/ipl/procs/typecode.icn new file mode 100644 index 0000000..5ad0360 --- /dev/null +++ b/ipl/procs/typecode.icn @@ -0,0 +1,41 @@ +############################################################################ +# +# File: typecode.icn +# +# Subject: Procedures to produce letter code for Icon type +# +# Author: Ralph E. Griswold +# +# Date: April 6, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# typecode(x) produces a one-letter string identifying the type of +# its argument. In most cases, the code is the first (lowercase) +# letter of the type, as "i" for the integer type. Structure types +# are in uppercase, as "L" for the list type. All records have the +# code "R". The code "C" is used for the co-expression type to avoid +# conflict for the "c" for the cset type. In the case of graphics, "w" +# is produced for windows. +# +############################################################################ + +procedure typecode(x) + local code + # be careful of records and their constructors + image(x) ? { + if ="record constructor " then return "p" + if ="record" then return "R" + } + + code := type(x) + + if code == ("list" | "set" | "table" | "co-expression") then + code := map(code,&lcase,&ucase) + + return code[1] +end diff --git a/ipl/procs/unsigned.icn b/ipl/procs/unsigned.icn new file mode 100644 index 0000000..6cf77af --- /dev/null +++ b/ipl/procs/unsigned.icn @@ -0,0 +1,43 @@ +############################################################################ +# +# File: unsigned.icn +# +# Subject: Procedure to put bits unsigned integer +# +# Author: Robert J. Alexander +# +# Date: April 2, 1990 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# unsigned() -- Puts raw bits of characters of string s into an +# integer. The value is taken as unsigned. +# +# If large integers are supported, this routine will work for integers +# of arbitrary size. +# +# If large integers are not supported, the following are true: +# +# If the size of s is the same as or greater than the size of an +# integer in the Icon implementation, the result will be negative or +# positive depending on the value of the integer's sign bit. +# +# If the size of s is less than the size of an integer, the bytes are +# put into the low order part of the integer, with the remaining high +# order bytes filled with zero. If the string is too large, the most +# significant bytes will be lost. +# +# This procedure is normally used for processing of binary data read +# from a file. +# + +procedure unsigned(s) + local i + i := 0 + every i := ior(ord(!s),ishift(i,8)) + return i +end diff --git a/ipl/procs/usage.icn b/ipl/procs/usage.icn new file mode 100644 index 0000000..f381c86 --- /dev/null +++ b/ipl/procs/usage.icn @@ -0,0 +1,68 @@ +############################################################################ +# +# File: usage.icn +# +# Subject: Procedures for service functions +# +# Author: Ralph E. Griswold +# +# Date: July 19, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures provide various common services: +# +# Usage(s) stops executions with a message concerning the +# expected form of usage of a program. +# +# Error(L[]) writes arguments to &errout and returns. +# +# +# ErrorCheck(l,f) reports an error that has been converted to +# failure. +# +# Feature(s) succeeds if feature s is available in the running +# implementation of Icon. +# +# Requires(s) terminates execution is feature s is not available. +# +# Signature() writes the version, host, and features support in +# the running implementation of Icon. +# +############################################################################ + +procedure Usage(s) + stop("Usage: ",s) +end + +procedure Error(L[]) + push(L,"*** ") + push(L, &errout) + write ! L +end + +procedure ErrorCheck(line,file) + if &errortext == "" then fail # No converted error + write("\nError ",&errornumber," at line ",line, " in file ",file) + write(&errortext) + write("offending value: ",image(&errorvalue)) + return +end + +procedure Feature(s) + if s == &features then return else fail +end + +procedure Requires(s) + if not(Feature(s)) then stop(s," required") +end + +procedure Signature() + write(&version) + write(&host) + every write(&features) +end diff --git a/ipl/procs/varsub.icn b/ipl/procs/varsub.icn new file mode 100644 index 0000000..4699bbd --- /dev/null +++ b/ipl/procs/varsub.icn @@ -0,0 +1,73 @@ +############################################################################ +# +# File: varsub.icn +# +# Subject: Procedure to perform UNIX-shell-style substitution +# +# Author: Robert J. Alexander +# +# Date: November 2, 1995 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Variable values are obtained from the supplied procedure, "varProc", +# which returns the value of its variable-name argument or fails if +# there is no such variable. "varProc" defaults to the procedure, +# "getenv". +# +# As with the UNIX Bourne shell and C shell, variable names are +# preceded by $. Optionally, the variable name can additionally be +# surrounded by curly braces {}, which is usually done when necessary +# to isolate the variable name from surrounding text. +# +# As with the C-shell, the special symbol ~<username> is handled. +# Username can be omitted, in which case the value of the variable +# "HOME" is substituted. If username is supplied, the /etc/passwd file +# is searched to supply the home directory of username (this action is +# obviously not portable to non-UNIX environments). +# +############################################################################ + +procedure varsub(s,varProc) + local var,p,user,pw,i,c,line + static nameChar + initial nameChar := &letters ++ &digits ++ "_" + /varProc := getenv + s ? { + s := "" + while s ||:= tab(upto('$~')) do { + p := &pos + s ||:= case move(1) of { + "$": { + if c := tab(any('{(')) then var := tab(find(map(c,"{(","})"))) & +move(1) + else var := tab(many(nameChar)) | "" + "" ~== varProc(\var) | &subject[p:&pos] + } + "~": { + if user := tab(many(nameChar)) || ":" then { + if pw := open("/etc/passwd") then { + (while line := read(pw) do + if match(user,line) then break) | (line := &null) + close(pw) + if \line then { + every i := find(":",line)\5 + i +:= 1 + line[i:find(":",line,i)] + } + else &subject[p:&pos] + } + else &subject[p:&pos] + } + else getenv("HOME") + } + } + } + s ||:= tab(0) + } + return s +end diff --git a/ipl/procs/verncnt.icn b/ipl/procs/verncnt.icn new file mode 100644 index 0000000..e759175 --- /dev/null +++ b/ipl/procs/verncnt.icn @@ -0,0 +1,39 @@ +############################################################################ +# +# File: verncnt.icn +# +# Subject: Procedure to compute number of n-digit versum numbers +# +# Author: Ralph E. Griswold +# +# Date: January 2, 1998 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure produces an approximation to the number of n-digit +# versum numbers, using a recurrence described in "Versum Numbers" in +# Icon Analyst 35. +# +############################################################################ + +procedure verncnt(n) #: number of n-digit versum numbers + + return case integer(n) of { + 1 : 4 + 2 : 14 + 3 : 93 + 4 : 256 + 5 : 1793 + 6 : 4872 + 7 : 34107 + 8 : 92590 + 9 : 648154 + 10 : 1759313 + default : 19 * verncnt(n - 2) + } + +end diff --git a/ipl/procs/version.icn b/ipl/procs/version.icn new file mode 100644 index 0000000..9d75ed9 --- /dev/null +++ b/ipl/procs/version.icn @@ -0,0 +1,30 @@ +############################################################################ +# +# File: version.icn +# +# Subject: Procedures to produce Icon version number +# +# Author: Ralph E. Griswold +# +# Date: September 2, 1991 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This procedure produces the version number of Icon on which a +# program is running. It only works if the &version is in the +# standard form. +# +############################################################################ + +procedure version() + + &version ? { + tab(find("Version ") + 8) | fail + tab(many('0123456789.')) ? return tab(-1) + } + +end diff --git a/ipl/procs/vhttp.icn b/ipl/procs/vhttp.icn new file mode 100644 index 0000000..3c2625d --- /dev/null +++ b/ipl/procs/vhttp.icn @@ -0,0 +1,248 @@ +############################################################################ +# +# File: vhttp.icn +# +# Subject: Procedure for validating an HTTP URL +# +# Author: Gregg M. Townsend +# +# Date: May 15, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# vhttp(url) validates a URL (a World Wide Web link) of HTTP: form +# by sending a request to the specified Web server. It returns a +# string containing a status code and message. If the URL is not +# in the proper form, or if it does not specify the HTTP: protocol, +# vhttp fails. +# +############################################################################ +# +# vhttp(url) makes a TCP connection to the Web server specified by the +# URL and sends a HEAD request for the specified file. A HEAD request +# asks the server to check the validity of a request without sending +# the file itself. +# +# The response code from the remote server is returned. This is +# a line containing a status code followed by a message. Here are +# some typical responses: +# +# 200 OK +# 200 Document follows +# 301 Moved Permanently +# 404 File Not Found +# +# See the HTTP protocol spec for more details. If a response cannot +# be obtained, vhttp() returns one of these invented codes: +# +# 551 Connection Failed +# 558 No Response +# 559 Empty Response +# +############################################################################ +# +# The request sent to the Web server can be parameterized by setting +# two global variables. +# +# The global variable vhttp_agent is passed to the Web server as the +# "User-agent:" field of the HEAD request; the default value is +# "vhttp.icn". +# +# The global variable vhttp_from is passed as the "From:" field of the +# HEAD request, if set; there is no default value. +# +############################################################################ +# +# vhttp() contains deliberate bottlenecks to prevent a naive program +# from causing annoyance or disruption to Web servers. No remote +# host is connected more than once a second, and no individual file +# is actually requested more than once a day. +# +# The request rate is limited to one per second by keeping a table +# of contacted hosts and delaying if necessary so that no host is +# contacted more than once in any particular wall-clock second. +# +# Duplicate requests are prevented by using a very simple cache. +# The file $HOME/.urlhist is used to record responses, and these +# responses are reused throughout a single calendar day. When the +# date changes, the cache is invalidated. +# +# These mechanisms are crude, but they are effective good enough to +# avoid overloading remote Web servers. In particular, a program +# that uses vhttp() can be run repeatedly with the same data without +# any effect after the first time on the Web servers referenced. +# +# The cache file, of course, can be defeated by deleting or editing. +# The most likely reason for this would be to retry connections that +# failed to complete on the first attempt. +# +############################################################################ +# +# Links: cfunc +# +############################################################################ +# +# Requires: Unix, dynamic loading +# +############################################################################ + +# To Do: +# +# Distinguish timeout on connect from other failures (check &clock?) + + + +link cfunc + +global vhttp_agent # User_agent: +global vhttp_from # From: + +$define HIST_FILE ".urlhist" # history file in $HOME +$define AGENT_NAME "vhttp.icn" # default agent name + +$define MAX_WAIT 60 # maximum wait after connect (seconds) + +$define HTTP_PORT 80 # standard HTTP: port + + + +procedure vhttp(url) #: validate HTTP: URL + local protocol, host, port, path, result + initial vhttp_inithist() + + /vhttp_agent := AGENT_NAME + url ? { + protocol := map(tab(upto(':'))) | fail + protocol == "http" | fail + ="://" | fail + host := map(tab(upto('/:') | 0)) | fail + if =":" then + port := tab(many(&digits)) | fail + else + port := HTTP_PORT + if pos(0) then + path := "/" + else + path := tab(0) + } + + if result := vhttp_histval(url) then + return result + + result := vhttp_contact(host, port, path) + vhttp_addhist(url, result) + return result +end + + + +# vhttp_contact(host, port, path) -- internal procedure for contacting server + +procedure vhttp_contact(host, port, path) + local f, line, hostport + static deadhosts + initial deadhosts := set() + + hostport := host || ":" || port + + if member(deadhosts, hostport) then + return "551 Connection Failed" + + vhttp_waitclock(host) + + if not (f := tconnect(host, port)) then { + insert(deadhosts, hostport) + return "551 Connection Failed" + } + + writes(f, "HEAD ", path, " HTTP/1.0\r\n") + writes(f, "User-agent: ", \vhttp_agent, "\r\n") + writes(f, "From: ", \vhttp_from, "\r\n") + writes(f, "Host: ", host, "\r\n") + writes(f, "\r\n") + flush(f) + seek(f, 1) + + if not fpoll(f, MAX_WAIT * 1000) then { + close(f) + return "558 No Response" + } + + if not (line := read(f)) then { + close(f) + return "559 Empty Response" + } + + close(f) + line ? { + tab(many(' ')) + if ="HTTP/" then tab(many('12345.67890')) + tab(many(' ')) + return trim(tab(0), ' \t\r\n\v\f') + } +end + + + +# vhttp_waitclock(host) -- internal throttling procedure + +procedure vhttp_waitclock(host) + static hclock, curclock + initial { + hclock := table() + curclock := &clock + } + + if hclock[host] === curclock then { + curclock := &clock + if hclock[host] === curclock then { + delay(1000) + curclock := &clock + } + } + + hclock[host] := curclock + return +end + + + +# internal history data and procedures + +global vhttp_htable, vhttp_hfile + +procedure vhttp_inithist() + local fname, line, key, val + + vhttp_htable := table() + fname := (getenv("HOME") | "?noHOME?") || "/" || HIST_FILE + if (vhttp_hfile := open(fname, "b")) & (read(vhttp_hfile) == &date) then { + while line := read(vhttp_hfile) do line ? { + key := tab(upto(' ')) | next + move(1) + val := tab(0) + vhttp_htable[key] := val + } + seek(vhttp_hfile, 0) # to allow switch to writing + } + else { + close(\vhttp_hfile) + vhttp_hfile := open(fname, "w") | stop("can't open " || fname) + write(vhttp_hfile, &date) + } + return +end + +procedure vhttp_histval(key) + return \vhttp_htable[key] +end + +procedure vhttp_addhist(key, val) + vhttp_htable[key] := val + write(vhttp_hfile, key, " ", val) + return val +end diff --git a/ipl/procs/vrml.icn b/ipl/procs/vrml.icn new file mode 100644 index 0000000..63e7e59 --- /dev/null +++ b/ipl/procs/vrml.icn @@ -0,0 +1,172 @@ +############################################################################ +# +# File: vrml.icn +# +# Subject: Procedures to support creation of VRML files +# +# Author: Ralph E. Griswold +# +# Date: May 2, 2001 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This file contains procedures for producing VRML files. +# +# point_field(L) create VRML point field from point list L +# +# u_crd_idx(i) create VRML coordinate index for 0 through i - 1 +# +# render(x) render node x +# +# vrml1(x) produces VRML 1.0 file for node x +# +# vrml2(x) produces VRML 2.0 file for node x +# +# vrml_color(s) convert Icon color specification to vrml form +# +# Notes: +# +# Not all node types have been tested. +# +# Where field values are complex, as in vectors, these must be built +# separately as strings to go in the appropriate fields. +# +# There is no error checking. Fields must be given in the +# order they appear in the node record declarations and field values +# must be of the correct type and form. +# +# The introduction of record types other than for nodes will cause +# bogus output. A structural loop will produce output until the +# evaluation stack overflows. +# +############################################################################ +# +# Links: ptutils, records +# +############################################################################ +# +# Requires: Version 9 graphics for color conversion +# +############################################################################ +# +# See also: vrml1lib.icn and vrml2.icn +# +############################################################################ + +link ptutils, records + +procedure point_field(pts) #: create VRML point field + local field + + field := "[\n" + + every field ||:= pt2coord(!pts) || ",\n" + + return field || "\n]" + +end + +procedure u_crd_idx(i) #: create VRML coordinate index + local index + + index := "[\n" + + every index ||:= (0 to i - 1) || ",\n" + + return index ||:= "\n]" + +end + + + + + +procedure vrml1(x, f) #: write VRML 1.0 file + + /f := &output + + write(f, "#VRML V1.0 ascii") + + render(x, f) + +end + +procedure vrml2(x, f) #: produce VRML 2.0 file + + write(f, "#VRML V2.0 utf8") + + render(x, f) + +end + +procedure render(x, f) # render VRML object + local i, bar, fieldname, input + static indent + + initial indent := 0 + + if /x then return # skip any stray null values + + indent +:= 3 + bar := repl(" ", indent) + + if x := string(x) then write(f, " ", x) + else case type(x) of { + "USE": write(f, bar, "USE ", x.name) + "DEF": { + writes(f, bar, "DEF ", x.name) + render(x.node, f) + } + "Comment": write(f, "# ", x.text) + "Include": { + input := open(x.name) | stop("*** cannot find inline file") + while write(f, read(input)) + close(input) + } + default: { # all other nodes + write(f, bar, type(x), " {") # must be record for VRML node + every i := 1 to *x do { + if type(x[i]) == "list" then # list of children + every render(!x[i], f) + else if /x[i] then next # skip empty fields + else { + writes(f, bar, " ") + fieldname := field(x, i) + if fieldname ~== "null" then writes(f, fieldname) + render(x[i], f) + } + } + write(f, bar, " }") + } + } + + indent -:= 3 + + return + +end + +procedure vrml_color(s) + local result + static factor + + initial factor := real(2 ^ 16 - 1) + + s := ColorValue(s) | fail + + result := "" + + s ? { + every 1 to 3 do { + result ||:= (tab(upto(',') | 0) / factor) || " " + move(1) + } + } + + return result + +end diff --git a/ipl/procs/vrml1lib.icn b/ipl/procs/vrml1lib.icn new file mode 100644 index 0000000..0eb07a9 --- /dev/null +++ b/ipl/procs/vrml1lib.icn @@ -0,0 +1,251 @@ +############################################################################ +# +# File: vrml1lib.icn +# +# Subject: Procedures to support construction of VRML 1.0 files +# +# Author: Ralph E. Griswold +# +# Date: November 19, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This file contains record declarations for VRML 1.0 nodes. +# +# Note: Although VRML 1.0 allows node fields to be given in any order, +# they must be specified in the order given in the record declarations +# that follow. +# +# Omitted (null-valued) fields are ignored on output. +# +# Group nodes require list arguments for lists of nodes. +# +############################################################################ +# +# See also: vrml2lib.icn, vrml.icn +# +############################################################################ + +record AsciiText( + string, + spacing, + justification, + width + ) + +record Color( + color + ) + +record Comment( + text + ) + +record Cone( + height, + bottomRadius, + parts + ) + +record Coordinate3( + point + ) + +record Cube( + width, + height, + depth + ) + +record Cylinder( + radius, + height, + parts + ) + +record DEF( + name, + node + ) + +record DirectionalLight( + on, + intensity, + color, + direction + ) + +record FontStyle( + family, + style, + size + ) + +record Group( + list + ) + +record Info( + string + ) + +record Include( + name + ) + +record IndexedFaceSet( + coordIndex, + materialIndex, + normalIndex, + textureCoordIndex + ) + +record IndexedLineSet( + coordIndex, + materialIndex, + normalIndex, + textureCoordIndex + ) + +record LOD( + center, + range + ) + +record Material( + diffuseColor, + ambientColor, + emissiveColor, + shininess, + specularColor, + transparency + ) + +record MaterialBinding( + value + ) + +record MatrixTransform( + matrix + ) + +record Normal( + vector + ) + +record NormalBinding( + value + ) + +record OrthographicCamera( + position, + orientation, + focalDistance, + height + ) + +record PerspectiveCamera( + position, + orientation, + focalDistance, + heightAngle, + nearDistance, + farDistance + ) + +record PointLight( + on, + location, + radius, + color + ) + +record PointSet( + startIndex, + numPoints + ) + +record Rotation( + rotation + ) + +record Scale( + scaleFactor + ) + +record Separator( + list, + renderCulling + ) + +record ShapeHints( + vertexOrdering, + shapeType, + faceType, + creaseAngle + ) + +record Sphere( + radius + ) + +record SpotLight( + on, + location, + direction, + intensity, + color, + dropOffRate, + cutOffAngle + ) + +record Switch( + whichChild, + children + ) + +record Texture2Transform( + translation, + rotation, + scaleFactor, + center + ) +record TextureCoordinate2( + point + ) + +record Transform( + translation, + rotation, + scaleFactor, + scaleOrientation, + center + ) + +record TransformSeparator( + children + ) + +record Translation( + translation + ) + +record USE( + name + ) + +record WWWAnchor( + name, + description, + map + ) + +record WWWInline( + name, + bboxSize, + bboxCenter + ) diff --git a/ipl/procs/vrml2lib.icn b/ipl/procs/vrml2lib.icn new file mode 100644 index 0000000..e1943af --- /dev/null +++ b/ipl/procs/vrml2lib.icn @@ -0,0 +1,508 @@ +############################################################################ +# +# File: vrml2lib.icn +# +# Subject: Procedures to support construction of VRML 2.0 files +# +# Author: Ralph E. Griswold +# +# Date: November 19, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This file contains record declarations for VRML 2.0 nodes. +# +# Note: Although VRML 2.0 allows node fields to be given in any order, +# they must be specified in the order given in the record declarations +# that follow. +# +# Group nodes require list arguments for lists of nodes. +# +############################################################################ + +record Anchor( + children, + bboxCenter, + bboxSize, + url, + parameter, + decsription, + addChildren, + removeChildren + ) + +record Appearance( + material, + texture, + textureTransform + ) + +record AudioClip( + url, + duration, + starttime, + stopTime, + pitch, + loop, + isActive, + duration_changed + ) + +record Background( + skyColor, + skyAngle, + groundCOlor, + groundAngle, + backUrl, + bottomUrl, + frontUrl, + leftUrl, + rightUrl, + topUrl, + set_bind, + bind_changed + ) + +record Billboard( + children, + axixOfRotation, + bboxCenter, + bboxSize, + addChildren, + removeChildren + ) + +record Box( + size + ) + +record Collision( + children, + collide, + bboxCenter, + bboxSize, + proxy, + collideTime, + addChildren, + removeChildren + ) + +record Color( + color + ) + +record ColorInterpolator( + key, + keyValue, + set_fraction, + value_changed + ) + +record Comment( + text + ) + +record Cone( + height, + bottomRadius, + side, + bottom + ) + +record Coordinate( + point + ) + +record CoordinateInterpolator( + key, + keyValue, + set_fraction, + value_changed + ) + +record Cylinder( + radius, + height, + side, + top, + bottom + ) + +record CylinderSensor( + enabled, + diskAngle, + autoOffset, + maxAngle, + minAngle, + isActive, + rotation_changed, + trackPoint_changed + ) + +record DirectionalLight( + on, + intensity, + ambientIntensity, + color, + direction + ) + +record ElevationGrid( + xDimension, + xSpacing, + zDimension, + zSpacing, + height, + color, + colorPerVertex, + normal, + normalPerVertex, + texCoord, + ccw, + solid, + creaseAngle, + set_height + ) + +record Extrusion( + crossSection, + spine, + scale, + orientation, + beginCap, + endCap, + ccw, + solid, + convex, + creaseAngle, + set_spine, + set_crossSection, + set_scale, + set_orientation + ) + +record Fog( + color, + visibilityRange, + fogType, + set_bind, + bind_changed + ) + +record FontStyle( + family, + style, + size, + spacing, + justify, + horizontal, + leftToRight, + topToBottom, + language + ) + +record Group( + children, + bboxCenter, + bboxSize, + addChildren, + removeChildren + ) + +record ImageTexture( + url, + repeatS, + repeatT + ) + +record Include( + name + ) + +record IndexedFaceSet( + coord, + coordIndex, + texCoord, + texCoordIndex, + color, + colorIndex, + colorPerVertex, + normal, + normalIndex, + normalPerVertex, + ccw, + convex, + solid, + creaseAngle, + set_coordIndex, + set_texCoordIndex, + set_colorIndex, + set_normalIndex + ) + +record IndexedLineSet( + coord, + coordIndex, + color, + colorIndex, + colorPerVertex, + set_coordIndex, + set_colorIndex + ) + +record Inline( + url, + bboxCenter, + bboxSize + ) + +record LOD( + center, + level, + range + ) + +record Material( + diffuseColor, + ambientIntensity, + emissiveColor, + shininess, + specularColor, + transparency + ) + +record MovieTexture( + url, + loop, + speed, + startTime, + stopTime, + repeatS, + repeatT, + isActive, + duration_changed + ) + +record NavigationInfo( + type, + speed, + avatarSize, + headlight, + visibilityLimit, + set_bind, + isBound + ) + +record Normal( + vector + ) + +record NormalInterpolator( + key, + keyValue, + set_fraction, + value_changed + ) + +record OrientationInterpolator( + key, + keyValue, + set_fraction, + value_changed + ) + +record PixelTexture( + image, + repeatS, + repeatT + ) + +record PlaneSensor( + enabled, + autoOffset, + offset, + maxPosition, + minPosition, + isActive, + translation_changed, + trackPoint_changed + ) + +record PointLight( + on, + location, + radius, + intensity, + ambientIntensity, + color, + attenuation + ) + +record PointSet( + coord, + color + ) + +record PositionInterpolator( + key, + keyValue, + set_fraction, + value_changed + ) + +record ProximitySensor( + enabled, + center, + size, + isActive, + enterTime, + exitTIme, + position_changed, + orientation_cahnged + ) + +record ScalarInterpolator( + key, + keyValue, + set_fraction, + value_changed + ) + +record Script( + url, + mustEvaluate, + directOutput, + list + ) + +record Shape( + appearance, + geometry + ) + +record Sound( + source, + intensity, + location, + direction, + minFront, + minBack, + maxFront, + maxBack, + priority, + spatialize + ) + +record Sphere( + radius + ) + +record SphereSensor( + enabled, + autoOffset, + offset, + isActive, + rotation_changed, + trackPoint_changed + ) + +record SpotLight( + on, + location, + direction, + radius, + intensity, + ambientIntensity, + color, + attenuation, + beamWidth, + cutOffAngle + ) + +record Switch( + children, + choice, + whichChoice + ) + +record Text( + string, + length, + maxExtent, + fontStyle + ) + +record TextureCoordinate( + point + ) + +record TextureTransform( + translation, + rotation, + scale, + center + ) + +record TimeSensor( + enabled, + startTime, + stopTime, + cycleInterval, + loop, + isActive, + time, + cycleTime, + fraction_changed + ) + +record TouchSensor( + enabled, + isActive, + isOver, + touchTime, + hitPoint_changed, + hitNOrmal_changed, + hitTexCoord_changed + ) + +record Transform( + children, + translation, + rotation, + scale, + scaleOrientation, + bboxCenter, + bboxSize, + center, + addChildren, + removeChildren + ) + +record Viewpoint( + position, + orientation, + fieldOfView, + description, + jump, + set_bind, + isBound, + bindTime + ) + +record VisibilitySensor( + enabled, + center, + size, + isActive, + enterTime, + exitTIme + ) + +record WorldInfo( + title, + info + ) diff --git a/ipl/procs/wdiag.icn b/ipl/procs/wdiag.icn new file mode 100644 index 0000000..1364e3a --- /dev/null +++ b/ipl/procs/wdiag.icn @@ -0,0 +1,43 @@ +############################################################################ +# +# File: wdiag.icn +# +# Subject: Procedure to write values with labels +# +# Author: Ralph E. Griswold +# +# Date: March 25, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# widag(s1, s2, ...) writes the values of the global variables named s1, s2, +# ... with s1, s2, ... as identifying labels. +# +# It writes a diagnostic message to standard error output if an +# argument is not the name of a global variable. +# +# Note that this procedure only works for global variables; there is +# no way it can access the local variables of the procedure from which +# it is called. +# +############################################################################ + + +procedure wdiag(names__[]) #: write labeled global values + local wlist__, s__ + + wlist__ := [] + + every put(wlist__, " ", s__ := !names__, "=") do + put(wlist__, image(variable(s__))) | + write(&errout, image(s__), " is not a variable") + + write ! wlist__ + + return + +end diff --git a/ipl/procs/weavgenr.icn b/ipl/procs/weavgenr.icn new file mode 100644 index 0000000..d5f888b --- /dev/null +++ b/ipl/procs/weavgenr.icn @@ -0,0 +1,50 @@ +############################################################################ +# +# File: weavgenr.icn +# +# Subject: Links to procedures related to sequence drafting +# +# Author: Ralph E. Griswold +# +# Date: August 3, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# AD HOC +# +############################################################################ +# +# Links: random +# +############################################################################ + +link random + +procedure shaftmap(s) #: produce shaft map for characters + local j, map_table + + map_table := table() + + j := 0 + + every /map_table[!s] := (j +:= 1) + + return map_table + +end + +procedure genshafts(s, tbl) #: generate shafts for string mapping + + suspend tbl[!s] + +end + +procedure genmapshafts(s1, s2) #: map string and generate shafts + + suspend genshafts(s1, shaftmap(s2)) + +end diff --git a/ipl/procs/weaving.icn b/ipl/procs/weaving.icn new file mode 100644 index 0000000..df8f8b2 --- /dev/null +++ b/ipl/procs/weaving.icn @@ -0,0 +1,269 @@ +############################################################################ +# +# File: weaving.icn +# +# Subject: Procedures to implement weaving expressions +# +# Author: Ralph E. Griswold +# +# Date: October 22, 1999 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures implement the weaving expressions supported by Painter +# and described in the PDF document "Advanced Weaving" that accompanies +# that application. +# +############################################################################ +# +# Links: strings +# +############################################################################ + +$define Domain "12345678" +$define DomainForward "1234567812345678" +$define DomainBackward "8765432187654321" + +procedure Between(p1, p2) + + DomainForward ? { + tab(upto(p1[-1]) + 1) + return tab(upto(p2[1])) + } + +end + +procedure Block(p1, p2) #: weaving block + local i, s, p3, counts + + if *p1 < *p2 then p1 := Extend(p1, *p2) | fail + else if *p2 < *p1 then p2 := Extend(p2, *p1) | fail + + counts := [] + + p2 ? { + while s := tab(upto('{')) do { + every put(counts, !s) + move(1) + put(counts, tab(upto('}'))) + move(1) + } + every put(counts, !tab(0)) + } + + p3 := "" + + every i := 1 to *p1 do + p3 ||:= repl(p1[i], counts[i]) + + return p3 + +end + +procedure DownRun(c1, c2) #: weaving downrun + + DomainBackward ? { + tab(upto(c1)) + return tab(upto(c2) + 1) + } + +end + +# CYCLES WRONG + +procedure DownUp(p1, p2, cycles) #: weaving downup + local i, p3 + + /cycles := 0 + + if *p1 < *p2 then p1 := Extend(p1, *p2) | fail + else if *p2 < *p1 then p2 := Extend(p2, *p1) | fail + + p3 := p1[1] + + if cycles > 0 then { + DomainForward ? { + tab(upto(p1[-1]) + 1) + p3 ||:= repl(move(8), cycles) + } + } + + every i := 1 to *p1 do { + p3 ||:= DownRun(p1[i], p2[i])[2:0] + p3 ||:= UpRun(p2[i], p1[i + 1])[2:0] # might fail + } + + return p3 + +end + +procedure Downto(p1, p2, cycles) #: weaving downto + local p3 + + p3 := p1 + + /cycles := 0 + + if cycles > 0 then { + DomainBackward ? { + tab(upto(p1[-1]) + 1) + p3 ||:= repl(move(8), cycles) + } + } + + DomainBackward ? { + tab(upto(p1[-1]) + 1) + return p3 || tab(upto(p2[1])) || p2 + } + +end + +procedure Extend(p, i) #: weaving extension + + if *p = 0 then fail + + i := integer(i) + + return case i of { + *p > i : left(p, i) + *p < i : left(repl(p, (i / *p) + 1), i) + default : p + } + +end + +procedure Interleave(p1, p2) #: weaving interleave + local i, p3 + + if *p1 < *p2 then p1 := Extend(p1, *p2) | fail + else if *p2 < *p1 then p2 := Extend(p2, *p1) | fail + + p3 := "" + + every i := 1 to *p1 do + p3 ||:= p1[i] || p2[i] + + return p3 + +end + +procedure Palindrome(p) #: weaving palindrome + + if *p = 1 then return p + else return p || reverse(p[2:-1]) + +end + +procedure Pbox(p1, p2) #: weaving pbox + local p3, i + + if *p2 ~= *p1 then p2 := Extend(p2, *p1) | fail + + p3 := "" + + every i := !p1 do + p3 ||:= p1[p2[i]] + + return p3 + +end + +procedure Permute(p1, p2) #: weaving permutation + local p3, chunk, i, j + + j := *p1 % *p2 + if j ~= 0 then p1 := Extend(p1, *p1 + *p2 - j) | fail + + p3 := "" + + p1 ? { + while chunk := move(*p2) do + every i := !p2 do + p3 ||:= chunk[i] + } + + return p3 + +end + +procedure Run(p, count) + + DomainForward ? { + tab(upto(p[-1]) + 1) + return repl(move(*Domain), count) + } + +end + +procedure Template(p1, p2) #: weaving Template + local p3, dlist, i, j, k + + dlist := [] + + every i := 1 to *p1 do + put(dlist, p1[i] - p1[1]) + + p3 := "" + + every j := 1 to *dlist do + every i := 1 to *p2 do { + k := p2[i] + dlist[j] + if k > 8 then k -:= 8 + p3 ||:= k + } + + return p3 + +end + +# CYCLES WRONG + +procedure UpDown(p1, p2, cycles) #: weaving updown + local p3, i + + /cycles := 0 + + if *p1 < *p2 then p1 := Extend(p1, *p2) | fail + else if *p2 < *p1 then p2 := Extend(p2, *p1) | fail + + p3 := p1[1] + + if cycles > 0 then { + DomainForward ? { + tab(upto(p1[-1]) + 1) + p3 ||:= repl(move(8), cycles) + } + } + + every i := 1 to *p1 do { + p3 ||:= UpRun(p1[i], p2[i])[2:0] + p3 ||:= DownRun(p2[i], p1[i + 1])[2:0] # might fail + } + + return p3 + +end + +procedure UpRun(c1, c2) #: weaving uprun + + DomainForward ? { + tab(upto(c1)) + return tab(upto(c2) + 1) + } + +end + +procedure Upto(p1, p2, cycles) #: weaving upto + local p3 + + /cycles := 0 + + p3 := p1 + + return p1 || Run(p1, cycles) || Between(p1, p2) || p2 + +end diff --git a/ipl/procs/weavutil.icn b/ipl/procs/weavutil.icn new file mode 100644 index 0000000..9cb18e8 --- /dev/null +++ b/ipl/procs/weavutil.icn @@ -0,0 +1,365 @@ +############################################################################ +# +# File: weavutil.icn +# +# Subject: Procedures to support numerical weavings +# +# Author: Ralph E. Griswold +# +# Date: April 13, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Links: expander, tables +# +############################################################################ + +link expander +link tables + +$define Mask ("123456789" || &letters || &cset[162:-1]) # NEEDS FIXING + +record analysis(rows, sequence, patterns) + +# PFL weaving parameters + +record PflParams(P, T) + +# Sequence-drafting database record + +record sdb(table, name) # specification database +record ldb(table, name) # specification database + +record ddb(table) # definition database +record edb(table) # expression database +record tdb(table) # tie-up database + +record pfd( # pattern-form draft + name, + threading, + treadling, + warp_colors, + weft_colors, + palette, + colors, + shafts, + treadles, + tieup, + liftplan, + drawdown + ) + +record isd( # internal structure draft + name, + threading, # list of shaft numbers + treadling, # list of treadle numbers + warp_colors, # list of indexes into color_list + weft_colors, # list of indexes into color_list + color_list, # list of colors + shafts, # number of shafts + treadles, # number of treadles + width, # image width + height, # image height + tieup, # tie-up row list + liftplan # liftplan matrix + ) + +procedure readpfd(input) # read PFD + local draft + + draft := pfd() + + draft.name := read(input) & + draft.threading := read(input) & + draft.treadling := read(input) & + draft.warp_colors := read(input) & + draft.weft_colors := read(input) & + draft.palette := read(input) & + draft.colors := read(input) & + draft.shafts := read(input) & + draft.treadles := read(input) & + draft.tieup := read(input) | fail + draft.liftplan := read(input) # may be missing + draft.drawdown := read(input) # may be missing + + return draft + +end + +procedure writepfd(output, pfd) #: write PFD + + write(output, pfd.name) + write(output, pfd.threading) + write(output, pfd.treadling) + write(output, pfd.warp_colors) + write(output, pfd.weft_colors) + write(output, pfd.palette) + write(output, pfd.colors) + write(output, pfd.shafts) + write(output, pfd.treadles) + write(output, pfd.tieup) + if *\pfd.liftplan > 0 then write(pfd.liftplan) else write() + + return + +end + +procedure expandpfd(pfd) #: expand PFD + + pfd := copy(pfd) + + pfd.threading := pfl2str(pfd.threading) + pfd.treadling := pfl2str(pfd.treadling) + pfd.warp_colors := pfl2str(pfd.warp_colors) + pfd.weft_colors := pfl2str(pfd.weft_colors) + + pfd.warp_colors := Extend(pfd.warp_colors, *pfd.threading) + pfd.weft_colors := Extend(pfd.weft_colors, *pfd.treadling) + + return pfd + +end + +# Write include file for seqdraft (old) + +procedure write_spec(name, spec, opt, mode) #: write weaving include file + local n, output + static bar + + initial bar := repl("#", 72) + + /opt := "w" + + output := open(name, opt) | fail + + if \mode == "drawdown" then write(output, "$define DrawDown") + + # Literals are output with image(). Other definitions are + # Icon expressions, enclosed in parentheses. + + write(output, "$define Comments ", image(spec.comments)) + write(output, "$define Name ", image(spec.name)) + write(output, "$define Palette ", image(spec.palette)) + write(output, "$define WarpColors (", check(spec.warp_colors), ")") + write(output, "$define WeftColors (", check(spec.weft_colors), ")") + write(output, "$define Breadth (", spec.breadth, ")") + write(output, "$define Length (", spec.length, ")") + write(output, "$define Threading (", check(spec.threading), ")") + write(output, "$define Treadling (", check(spec.treadling), ")") + write(output, "$define Shafts (", spec.shafts, ")") + write(output, "$define Treadles (", spec.treadles, ")") + write(output, "$define Tieup ", image(spec.tieup)) + write(output, "$define Threads ", spec.links[1]) + write(output, "$define Treads ", spec.links[2]) + + every n := !keylist(spec.defns) do + write(output, "$define ", n, " ", spec.defns[n]) + + write(output, bar) + + close(output) + + return + +end + +# Write include file for seqdraft (new) + +procedure write_spec1(name, spec, opt, mode, defns) #: weaving include file + local n, output + static bar + + initial bar := repl("#", 72) + + /opt := "w" + + output := open(name, opt) | fail + + if \mode == "drawdown" then write(output, "$define DrawDown") + + # Literals are output with image(). Other definitions are + # Icon expressions, enclosed in parentheses. + + write(output, "$define Comments ", image(spec.comments)) + write(output, "$define Name ", image(spec.name)) + write(output, "$define Palette ", image((\spec.palette).name)) +# write(output, "$define WarpPalette ", image((\spec.warp_palette).name)) +# write(output, "$define WeftPalette ", image((\spec.weft_palette).name)) + write(output, "$define WarpColors (", check(spec.warp_colors), ")") + write(output, "$define WeftColors (", check(spec.weft_colors), ")") + write(output, "$define Breadth (", spec.breadth, ")") + write(output, "$define Length (", spec.length, ")") + write(output, "$define Threading (", check(spec.threading), ")") + write(output, "$define Treadling (", check(spec.treadling), ")") + write(output, "$define Shafts (", spec.shafts, ")") + write(output, "$define Treadles (", spec.treadles, ")") + write(output, "$define Tieup ", spec.tieup) + write(output, "$define Threads ", spec.links[1]) + write(output, "$define Treads ", spec.links[2]) + + every n := !keylist(spec.defns) do + write(output, "$define ", n, " ", spec.defns[n]) + + if \defns then + every n := !keylist(defns) do + write(output, "$define ", n, " ", defns[n]) + + write(output, bar) + + close(output) + + return + +end + +# Write include file for lstdraft (new) + +procedure write_spec2(name, spec, opt, mode, defns) #: weaving include file + local n, output + static bar + + initial bar := repl("#", 72) + + /opt := "w" + + output := open(name, opt) | fail + + if \mode == "drawdown" then write(output, "$define DrawDown") + + # Literals are output with image(). Other definitions are + # Icon expressions, enclosed in parentheses. + + write(output, "$define Comments ", image(spec.comments)) + write(output, "$define Name ", image(spec.name)) + write(output, "$define Palette ", image((\spec.palette))) + write(output, "$define WarpPalette ", image((\spec.warp_palette))) + write(output, "$define WeftPalette ", image((\spec.weft_palette))) + write(output, "$define WarpColors (", spec.warp_colors, ")") + write(output, "$define WeftColors (", spec.weft_colors, ")") + write(output, "$define Breadth (", spec.breadth, ")") + write(output, "$define Length (", spec.length, ")") + write(output, "$define Threading (", spec.threading, ")") + write(output, "$define Treadling (", spec.treadling, ")") + write(output, "$define Shafts (", spec.shafts, ")") + write(output, "$define Treadles (", spec.treadles, ")") + write(output, "$define Tieup ", spec.tieup) + write(output, "$define Threads ", spec.links[1]) + write(output, "$define Treads ", spec.links[2]) + + every n := !keylist(spec.defns) do + write(output, "$define ", n, " ", spec.defns[n]) + + if \defns then + every n := !keylist(defns) do + write(output, "$define ", n, " ", defns[n]) + + write(output, bar) + + close(output) + + return + +end + +procedure check(s) #: check for pattern form + + if s[1] == "[" then s := "!pfl2str(" || image(s) || ")" + + return s + +end + +procedure display(pfd) + + write(&errout, "name=", pfd.name) + write(&errout, "threading=", pfd.threading) + write(&errout, "treadling=", pfd.treadling) + write(&errout, "warp colors=", pfd.warp_colors) + write(&errout, "weft colors=", pfd.weft_colors) + write(&errout, "tie up=", limage(pfd.tieup)) + write(&errout, "palette=", pfd.palette) + + return + +end + +procedure sympos(sym) #: position of symbol in symbol list + static mask + + initial mask := Mask + + return upto(sym, mask) # may fail + +end + +procedure possym(i) #: symbol in position i of symbol list + static mask + + initial mask := Mask + + return mask[i] # may fail + +end + +# Procedure to convert a tier to a list of productions + +$define Different 2 + +procedure tier2prodl(tier, name) + local rows, row, count, unique, prodl, prod + + unique := table() + rows := [] + count := 0 + + every row := !tier.matrix do { + if /unique[row] then unique[row] := (count +:= 1) + put(rows, unique[row]) + } + + prod := name || "->" + every prod ||:= possym(!rows + Different) + + prodl := [ + "name:" || "t-" || name, + "comment: ex pfd2wpg " || &dateline, + "axiom:2", + "gener:1", + prod + ] + unique := sort(unique, 4) + + while row := get(unique) do + put(prodl, possym(get(unique) + Different) || "->" || row) + + put(prodl, "end:") + + return prodl + +end + +procedure analyze(drawdown) + local sequence, rows, row, count, patterns + + sequence := [] + patterns := [] + + rows := table() + + count := 0 + + every row := !drawdown do { + if /rows[row] then { + rows[row] := count +:= 1 + put(patterns, row) + } + put(sequence, rows[row]) + } + + return analysis(rows, sequence, patterns) + +end diff --git a/ipl/procs/weighted.icn b/ipl/procs/weighted.icn new file mode 100644 index 0000000..6bbcee5 --- /dev/null +++ b/ipl/procs/weighted.icn @@ -0,0 +1,87 @@ +############################################################################ +# +# File: weighted.icn +# +# Subject: Procedure to shuffle list with randomness +# +# Author: Erik Eid +# +# Date: May 23, 1994 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# WeightedShuffle returns the list "sample" with only a portion of the +# elements switched. Examples: +# +# L := WeightedShuffle (X, 100) - returns a fully shuffled list +# L := WeightedShuffle (X, 50) - every other element is eligible to +# be switched +# L := WeightedShuffle (X, 25) - every fourth element is shuffled +# L := WeightedShuffle (X, 0) - nothing is changed +# +# The procedure will fail if the given percentage is not between 0 and +# 100, inclusive, or if it is not a numeric value. +# +############################################################################ + +procedure WeightedShuffle (sample, percentage) +local lcv, pairs, weight, size, newlist, legal, illegal + numeric(percentage) | fail + (0 <= percentage <= 100) | fail + newlist := copy(sample) # Start with a copy of the + # original list. + size := *newlist + legal := list() # This list will hold which + # indices are valid choices for + # the shuffle, amounting to the + # selected percentage of all + # elements. + +# There are two very similar methods used here. I found that using only the +# first one created some odd values for 50 < percentage < 100, so I mirrored +# the technique to create a list of "bad" indices instead of a list of +# "good" indices that the random switch can choose from. + + if ((percentage <= 50) | (percentage = 100)) then { + pairs := integer (size * percentage / 100) + # Number of pairs to be switched. + if pairs > 0 then { # Makes sure to avoid division by + # zero- occurs when there is no + # need to shuffle. + weight := integer ((real(size) / pairs) + 0.5) + # Holds increment used in + # selective shuffling, rounded up. + lcv := 1 + until lcv > size do { + put (legal, lcv) # These indices may be used in + # the shuffle. + lcv +:= weight + } + } + } + else { # percentage > 50 + pairs := integer (size * (100 - percentage) / 100) + # Avoid switching this many pairs. + if pairs > 0 then { + weight := integer (size / pairs) # Increment, rounded down. + illegal := set ([]) # Which indices can't be used? + lcv := 1 + until lcv > size do { + illegal ++:= set([lcv]) # Compile the list of invaild + # indices. + lcv +:= weight + } + every lcv := 1 to size do # Whatever isn't bad is good. + if not member (illegal, lcv) then put (legal, lcv) + } + } + every newlist[!legal] :=: newlist[?legal] + # Shuffle elements only from + # legal indices. + return newlist +end + diff --git a/ipl/procs/wildcard.icn b/ipl/procs/wildcard.icn new file mode 100644 index 0000000..a0f6af6 --- /dev/null +++ b/ipl/procs/wildcard.icn @@ -0,0 +1,186 @@ +############################################################################ +# +# File: wildcard.icn +# +# Subject: Procedures for UNIX-like wild-card pattern matching +# +# Author: Robert J. Alexander +# +# Date: September 26, 1990 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# This is a kit of procedures to deal with UNIX-like filename wild-card +# patterns containing *, ?, and [...]. The meanings are as of the +# pattern characters are the same as in the UNIX shells csh and sh. +# They are described briefly in the wild_pat() procedure. +# +# These procedures are interesting partly because of the "recursive +# suspension" technique used to simulate conjunction of an arbitrary +# number of computed expressions. +# +# +# The public procedures are: +# +# wild_match(pattern,s,i1,i2) : i3,i4,...,iN +# wild_find(pattern,s,i1,i2) : i3,i4,...,iN +# +# wild_match() produces the sequence of positions in "s" past a +# substring starting at "i1" that matches "pattern", but fails if there +# is no such position. Similar to match(), but is capable of +# generating multiple positions. +# +# wild_find() produces the sequence of positions in "s" where +# substrings begin that match "pattern", but fails if there is no such +# position. Similar to find(). +# +# "pattern" can be either a string or a pattern list -- see wild_pat(), +# below. +# +# Default values of s, i1, and i2 are the same as for Icon's built-in +# string scanning procedures such as match(). +# +# +# wild_pat(s) : L +# +# Creates a pattern element list from pattern string "s". A pattern +# element is needed by wild_match() and wild_find(). wild_match() and +# wild_find() will automatically convert a pattern string to a pattern +# list, but it is faster to do the conversion explicitly if multiple +# operations are done using the same pattern. +# + +procedure wild_match(plist,s,i1,i2) # i3,i4,...,iN +# +# Produce the sequence of positions in s past a string starting at i1 +# that matches the pattern plist, but fails if there is no such +# position. Similar to match(), but is capable of generating multiple +# positions. +# + /i1:= if /s := &subject then &pos else 1 ; /i2 := 0 + plist := (if type(plist) == "string" then wild_pat else copy)(plist) + suspend s[i1:i2] ? (wild_match1(plist) & i1 + &pos - 1) +end + + +procedure wild_find(plist,s,i1,i2) # i3,i4,...,iN +# +# Produce the sequence of positions in s where strings begin that match +# the pattern plist, but fails if there is no such position. Similar +# to find(). +# + local p + /i1 := if /s := &subject then &pos else 1 ; /i2 := 0 + if type(plist) == "string" then plist := wild_pat(plist) + s[i1:i2] ? suspend ( + wild_skip(plist) & + p := &pos & + tab(wild_match(plist))\1 & + i1 + p - 1) +end + + +procedure wild_pat(s) # L +# +# Produce pattern list representing pattern string s. +# + local c,ch,chars,complement,e,plist,special + # + # Create a list of pattern elements. Pattern strings are parsed + # and converted into list elements as follows: + # + # * --> 0 Match any substring (including empty) + # ? --> 1 Matches any single character + # [abc] --> 'abc' Matches single character in 'abc' (more below) + # abc --> "abc" Matches "abc" + # \ Escapes the following character, causing it + # to be considered part of a string to match + # rather than one of the special pattern + # characters. + # + plist := [] + s ? { + until pos(0) do { + c := &null + # + # Put pattern element on list. + # + e := (="*" & 0) | (="?" & 1) | (="\\" & move(1)) | + (="[" & c := (=("]" | "!]" | "!-]" | "") || tab(find("]"))) & + move(1)) | + move(1) || tab(upto('*?[\\') | 0) + # + # If it's [abc], create a cset. Special notations: + # + # A-Z means all characters from A to Z inclusive. + # ! (if first) means any character not among those specified. + # - or ] (if first, or after initial !) means itself. + # + \c ? { + complement := ="!" | &null + special := '-]' + e := '' + while ch := tab(any(special)) do { + e ++:= ch + special --:= ch + } + while chars := tab(find("-")) do { + move(1) + e ++:= chars[1:-1] ++ + &cset[ord(chars[-1]) + 1:ord(move(1)) + 2] + } + e ++:= tab(0) + if \complement then e := ~e + } + if type(e) == "string" == type(plist[-1]) then plist[-1] ||:= e + else put(plist,e) + } + } + return plist +end + + +procedure wild_skip(plist) # s1,s2,...,sN +# +# Used privately -- match a sequence of strings in s past which a match +# of the first pattern element in plist is likely to succeed. This +# procedure is used for heuristic performance improvement by +# wild_match() for the "*" pattern element by matching only strings +# where the next element is likely to succeed, and by wild_find() to +# attempt matches only at likely positions. +# + local x,t + x := plist[1] + suspend tab( + case type(x) of { + "string": find(x) + "cset": upto(x) + default: &pos to *&subject + 1 + } + ) +end + + +procedure wild_match1(plist,v) # s1,s2,...,sN +# +# Used privately by wild_match() to simulate a computed conjunction +# expression via recursive suspension. +# + local c + if c := pop(plist) then { + suspend wild_match1(plist,case c of { + 0: wild_skip(plist) + 1: move(1) + default: case type(c) of { + "cset": tab(any(c)) + default: =c + } + }) + push(plist,c) + } + else return v +end diff --git a/ipl/procs/word.icn b/ipl/procs/word.icn new file mode 100644 index 0000000..1c7247a --- /dev/null +++ b/ipl/procs/word.icn @@ -0,0 +1,75 @@ +############################################################################ +# +# File: word.icn +# +# Subject: Procedure to scan UNIX-style command line words +# +# Author: Robert J. Alexander +# +# Date: August 14, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# word(s) -- Produces the position past a UNIX-style command line +# word. +# +# dequote(s) -- Produces the UNIX-style command line word s with any +# quoting characters removed. +# +############################################################################ +# +# Links: scanset +# +############################################################################ + +link scanset + +# +# word(s) -- Produces the position past a UNIX-style command line +# word. +# +procedure word(s,i1,i2) + local c,d,p,e,x + x := scan_setup(s,i1,i2) + x.ss ? { + (while tab(upto(' \t"\'')) do { + if (c := move(1)) == ("\"" | "'") then { + e := c ++ "\\" + while tab(upto(e)) do { + d := move(1) + if d == c then break + move(1) + } + } + else break + }) | "" ~== tab(0) | fail + p := &pos + } + return x.offset + p +end + + +# +# dequote(s) -- Produces the UNIX-style command line word s with any +# quoting characters removed. +# + +procedure word_dequote(s) + local c,d + s ? { + s := "" + while s ||:= tab(upto('"\'\\')) do { + c := move(1) + if c == "\\" then s ||:= move(1) + else { + if \d then (s ||:= d ~== c) | (d := &null) + else d := c + } + } + return s || tab(0) + } +end diff --git a/ipl/procs/wrap.icn b/ipl/procs/wrap.icn new file mode 100644 index 0000000..2595bfb --- /dev/null +++ b/ipl/procs/wrap.icn @@ -0,0 +1,105 @@ +############################################################################ +# +# File: wrap.icn +# +# Subject: Procedures to wrap output lines +# +# Author: Robert J. Alexander +# +# Date: December 5, 1989 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# wrap(s,i) -- Facilitates accumulation of small strings into longer +# output strings, outputting when the accumulated string would +# exceed a specified length (e.g. outputting items in multiple +# columns). +# +# s -- string to accumulate +# i -- width of desired output string +# +# Wrap fails if the string s did not necessitate output of the buffered +# output string; otherwise the output string is returned (which never +# includes s). +# +# s defaults to the empty string (""), causing nothing to be +# accumulated; i defaults to 0, forcing output of any buffered string. +# Note that calling wrap() with no arguments produces the buffer (if it +# is not empty) and clears it. +# +# Wrap does no output to files. +# +# +# Here's how wrap is normally used: +# +# wrap() # Initialize (not really necessary unless +# # a previous use might have left stuff in +# # the buffer). +# +# every i := 1 to 100 do # Loop to process strings to output -- +# write(wrap(x[i],80)) # only writes when 80-char line filled. +# +# write(wrap()) # Output what's in buffer -- only outputs +# # if something to write. +# +# +# wraps(s,i) -- Facilitates managing output of numerous small strings +# so that they do not exceed a reasonable line length (e.g. +# outputting items in multiple columns). +# +# s -- string to accumulate +# i -- maximum width of desired output string +# +# If the string "s" did not necessitate a line-wrap, the string "s" is +# returned. If a line-wrap is needed, "s", preceded by a new-line +# character ("\n"), is returned. +# +# "s" defaults to the empty string (""), causing nothing to be +# accumulated; i defaults to 0, forcing a new line if anything had been +# output on the current line. Thus calling wraps() with no arguments +# reinitializes it. +# +# Wraps does no output to files. +# +# +# Here's how wraps is normally used: +# +# wraps() # Initialize (not really necessary unless +# # a previous use might have left it in an +# # unknown condition). +# +# every i := 1 to 100 do # Loop to process strings to output -- +# writes(wraps(x[i],80))# only wraps when 80-char line filled. +# +# writes(wraps()) # Only outputs "\n" if something written +# # on last line. +# +############################################################################ + +procedure wrap(s,i) + local t + static line + initial line := "" + /s := "" ; /i := 0 + if *(t := line || s) > i then + return "" ~== (s :=: line) + line := t +end + +procedure wraps(s,i) + local t + static size + initial size := 0 + /s := "" ; /i := 0 + t := size + *s + if t > i & size > 0 then { + size := *s + return "\n" || s + } + size := t + return s +end diff --git a/ipl/procs/writecpt.icn b/ipl/procs/writecpt.icn new file mode 100644 index 0000000..0591612 --- /dev/null +++ b/ipl/procs/writecpt.icn @@ -0,0 +1,40 @@ +############################################################################ +# +# File: writecpt.icn +# +# Subject: Procedure to write a "carpet" file +# +# Author: Ralph E. Griswold +# +# Date: August 7, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# write_cpt(output, carpet) writes the carpet with heading information to +# the specified file. +# +############################################################################ +# +# Links: matrix +# +############################################################################ + +link matrix + +procedure write_cpt(output, carpet) #: convert matrix to numerical carpet + local min, max, i, j, width, height + + width := matrix_width(carpet) + height := matrix_height(carpet) + + write(output, "width=", width, " height=", height) + + write_matrix(output, carpet) + + return + +end diff --git a/ipl/procs/xcode.icn b/ipl/procs/xcode.icn new file mode 100644 index 0000000..0edfe99 --- /dev/null +++ b/ipl/procs/xcode.icn @@ -0,0 +1,444 @@ +############################################################################ +# +# File: xcode.icn +# +# Subject: Procedures to save and restore Icon data +# +# Author: Bob Alexander +# +# Date: November 19, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Contributor: Ralph E. Griswold +# +############################################################################ +# +# Description +# ----------- +# +# These procedures provide a way of storing Icon values in files +# and retrieving them. The procedure xencode(x,f) stores x in file f +# such that it can be converted back to x by xdecode(f). These +# procedures handle several kinds of values, including structures of +# arbitrary complexity and even loops. The following sequence will +# output x and recreate it as y: +# +# f := open("xstore","w") +# xencode(x,f) +# close(f) +# f := open("xstore") +# y := xdecode(f) +# close(f) +# +# For "scalar" types -- null, integer, real, cset, and string, the +# above sequence will result in the relationship +# +# x === y +# +# For structured types -- list, set, table, and record types -- +# y is, for course, not identical to x, but it has the same "shape" and +# its elements bear the same relation to the original as if they were +# encoded and decoded individually. +# +# Files, co-expressions, and windows cannot generally be restored in any +# way that makes much sense. These objects are restored as empty lists so +# that (1) they will be unique objects and (2) will likely generate +# run-time errors if they are (probably erroneously) used in +# computation. However, the special files &input, &output, and &errout are +# restored. +# +# Not much can be done with functions and procedures, except to preserve +# type and identification. +# +# The encoding of strings and csets handles all characters in a way +# that it is safe to write the encoding to a file and read it back. +# +# xdecode() fails if given a file that is not in xcode format or it +# the encoded file contains a record for which there is no declaration +# in the program in which the decoding is done. Of course, if a record +# is declared differently in the encoding and decoding programs, the +# decoding may be bogus. +# +# xencoden() and xdecoden() perform the same operations, except +# xencoden() and xdecoden() take the name of a file, not a file. +# +# xencodet() and xdecodet() are like xencode() and xdecode() +# except that the trailing argument is a type name. If the encoded +# decoded value is not of that type, they fail. xencodet() does +# not take an opt argument. +# +############################################################################ +# +# Complete calling sequences +# -------------------------- +# +# xencode(x, f, p) # returns f +# +# where +# +# x is the object to encode +# +# f is the file to write (default &output) +# +# p is a procedure that writes a line on f using the +# same interface as write() (the first parameter is +# always a the value passed as "file") (default: write) +# +# +# xencode(f, p) # returns the restored object +# +# where +# +# f is the file to read (default &input) +# +# p is a procedure that reads a line from f using the +# same interface as read() (the parameter is +# always a the value passed as "file") (default: read) +# +# +# The "p" parameter is not normally used for storage in text files, but +# it provides the flexibility to store the data in other ways, such as +# a string in memory. If "p" is provided, then "f" can be any +# arbitrary data object -- it need not be a file. +# +# For example, to "write" x to an Icon string: +# +# record StringFile(s) +# +# procedure main() +# ... +# encodeString := xencode(x,StringFile(""),WriteString).s +# ... +# end +# +# procedure WriteString(f,s[]) +# every f.s ||:= !s +# f.s ||:= "\n" +# return +# end +# +############################################################################ +# +# Notes on the encoding +# --------------------- +# +# Values are encoded as a sequence of one or more lines written to +# a plain text file. The first or only line of a value begins with a +# single character that unambiguously indicates its type. The +# remainder of the line, for some types, contains additional value +# information. Then, for some types, additional lines follow +# consisting of additional object encodings that further specify the +# object. The null value is a special case consisting of an empty +# line. +# +# Each object other than &null is assigned an integer tag as it is +# encoded. The tag is not, however, written to the output file. On +# input, tags are assigned in the same order as objects are decoded, so +# each restored object is associated with the same integer tag as it +# was when being written. In encoding, any recurrence of an object is +# represented by the original object's tag. Tag references are +# represented as integers, and are easily recognized since no object's +# representation begins with a digit. +# +# Where a structure contains elements, the encodings of the +# elements follow the structure's specification on following lines. +# Note that the form of the encoding contains the information needed to +# separate consecutive elements. +# +# Here are some examples of values and their encodings: +# +# x encode(x) +# ------------------------------------------------------- +# +# 1 N1 +# 2.0 N2.0 +# &null +# "\377" "\377" +# '\376\377' '\376\377' +# procedure main p +# "main" +# co-expression #1 (0) C +# [] L +# N0 +# set() "S" +# N0 +# table("a") T +# N0 +# "a" +# ["hi","there"] L +# N2 +# "hi" +# "there" +# +# A loop is illustrated by +# +# L2 := [] +# put(L2,L2) +# +# for which +# +# x encode(x) +# ------------------------------------------------------- +# +# L2 L +# N1 +# 2 +# +# The "2" on the third line is a tag referring to the list L2. The tag +# ordering specifies that an object is tagged *after* its describing +# objects, thus the list L2 has the tag 2 (the integer 1 has tag 1). +# +# Of course, you don't have to know all this to use xencode and +# xdecode. +# +############################################################################ +# +# Links: escape +# +############################################################################ +# +# See also: codeobj.icn +# +############################################################################ + +link escape + +record xcode_rec(file,ioProc,done,nextTag) + +procedure xencode(x,file,writeProc) #: write structure to file + + /file := &output + return xencode_1( + xcode_rec( + file, + (\writeProc | write) \ 1, + table(), + 0), + x) +end + +procedure xencode_1(data,x) + local tp,wr,f,im + wr := data.ioProc + f := data.file + # + # Special case for &null. + # + if /x then { + wr(f) + return f + } + # + # If this object has already been output, just write its tag. + # + if tp := \data.done[\x] then { + wr(f,tp) + return f + } + # + # Check to see if it's a "distinguished" that is represented by + # a keyword (special files and csets). If so, just use the keyword + # in the output. + # + im := image(x) + if match("integer(", im) then im := string(x) + else if match("&",im) then { + wr(f,im) + data.done[x] := data.nextTag +:= 1 + return f + } + # + # Determine the type and handle accordingly. + # + tp := case type(x) of { + "cset" | "string": "" + "file" | "window": "f" + "integer" | "real": "N" + "co-expression": "C" + "procedure": "p" + "list": "L" + "set": "S" + "table": "T" + default: "R" + } + case tp of { + # + # String, cset, or numeric outputs its string followed by its + # image. + # + "" | "N": wr(f,tp,im) + # + # Procedure writes "p" followed (on subsequent line) by its name + # as a string object. + # + "p": { + wr(f,tp) + im ? { + while tab(find(" ") + 1) + xencode_1(data,tab(0)) + } + } + # + # Co-expression, or file just outputs its letter. + # + !"CEf": wr(f,tp) + # + # Structured type outputs its letter followed (on subsequent + # lines) by additional data. A record writes its type as a + # string object; other type writes its size as an integer object. + # Structure elements follow on subsequent lines (alternating keys + # and values for tables). + # + default: { + wr(f,tp) + case tp of { + !"LST": { + im ? { + tab(find("(") + 1) + xencode_1(data,integer(tab(-1))) + } + if tp == "T" then xencode_1(data,x[[]]) + } + default: xencode_1(data,type(x)) + } + # + # Create the tag. It's important that the tag is assigned + # *after* other other objects that describe this object (e.g. + # the length of a list) are output (and tagged), but *before* + # the structure elements; otherwise decoding would be + # difficult. + # + data.done[x] := data.nextTag +:= 1 + # + # Output the elements of the structure. + # + every xencode_1(data, + !case tp of {"S": sort(x); "T": sort(x,3); default: x}) + } + } + # + # Tag the object if it's not already tagged. + # + /data.done[x] := data.nextTag +:= 1 + return f +end + +procedure xdecode(file,readProc) #: read structure from file + + /file := &input + + return xdecode_1( + xcode_rec( + file, + (\readProc | read) \ 1, + [])) +end + +# This procedure fails if it encounters bad data + +procedure xdecode_1(data) + local x,tp,sz, i + data.ioProc(data.file) ? { + if any(&digits) then { + # + # It's a tag -- return its value from the object table. + # + return data.done[tab(0)] + } + if tp := move(1) then { + x := case tp of { + "N": numeric(tab(0)) + "\"": escape(tab(-1)) + "'": cset(escape(tab(-1))) + "p": proc(xdecode_1(data)) | fail + "L": list(xdecode_1(data)) | fail + "S": {sz := xdecode_1(data) | fail; set()} + "T": {sz := xdecode_1(data) | fail; table(xdecode_1(data)) | fail} + "R": proc(xdecode_1(data))() | fail + "&": case tab(0) of { + # + # Special csets. + # + "cset": &cset + "ascii": &ascii + "digits": &digits + "letters": &letters + "lcase": &lcase + "ucase": &ucase + # + # Special files. + # + "input": &input + "output": &output + "errout": &errout + default: [] # so it won't crash if new keywords arise + } + "f" | "C": [] # unique object for things that can't + # be restored. + default: fail + } + put(data.done,x) + case tp of { + !"LR": every i := 1 to *x do + x[i] := xdecode_1(data) | fail + "T": every 1 to sz do + insert(x,xdecode_1(data),xdecode_1(data)) | fail + "S": every 1 to sz do + insert(x,xdecode_1(data)) | fail + } + return x + } + else return + } + +end + +procedure xencoden(x, name, opt) + local output + + /opt := "w" + + output := open(name, opt) | stop("*** xencoden(): cannot open ", name) + xencode(x, output) + close(output) + + return + +end + +procedure xencodet(x, file, typ) + + if type(x) === typ then return xencode(x, file) + else fail + +end + +procedure xdecodet(file, typ) + local x + + x := xdecode(file) + + if type(x) == typ then return x + else fail + +end + +procedure xdecoden(name) + local input, x + + input := open(name) | stop("*** xdecoden(): cannot open ", name) + if x := xdecode(input) then { + close(input) + return x + } + else { + close(input) + fail + } + +end diff --git a/ipl/procs/xcodes.icn b/ipl/procs/xcodes.icn new file mode 100644 index 0000000..023b8dc --- /dev/null +++ b/ipl/procs/xcodes.icn @@ -0,0 +1,452 @@ +############################################################################ +# +# File: xcodes.icn +# +# Subject: Procedures to save and restore Icon data +# +# Author: Bob Alexander +# +# Date: November 19, 1997 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Contributor: Ralph E. Griswold +# +############################################################################ +# +# Note: This version handles the encoding of records using canonical +# names: record0, record1, ... . This allows programs to decode files +# by providing declarations for these names when the original declarations +# are not available. This version also provides for procedures and +# files present in the encoded file that are not in the decoding program. +# +# This version should be merged with the ordinary version. +# +# Description +# ----------- +# +# These procedures provide a way of storing Icon values in files +# and retrieving them. The procedure xencode(x,f) stores x in file f +# such that it can be converted back to x by xdecode(f). These +# procedures handle several kinds of values, including structures of +# arbitrary complexity and even loops. The following sequence will +# output x and recreate it as y: +# +# f := open("xstore","w") +# xencode(x,f) +# close(f) +# f := open("xstore") +# y := xdecode(f) +# close(f) +# +# For "scalar" types -- null, integer, real, cset, and string, the +# above sequence will result in the relationship +# +# x === y +# +# For structured types -- list, set, table, and record types -- +# y is, for course, not identical to x, but it has the same "shape" and +# its elements bear the same relation to the original as if they were +# encoded and decoded individually. +# +# Files, co-expressions, and windows cannot generally be restored in any +# way that makes much sense. These objects are restored as empty lists so +# that (1) they will be unique objects and (2) will likely generate +# run-time errors if they are (probably erroneously) used in +# computation. However, the special files &input, &output, and &errout are +# restored. +# +# Not much can be done with functions and procedures, except to preserve +# type and identification. +# +# The encoding of strings and csets handles all characters in a way +# that it is safe to write the encoding to a file and read it back. +# +# xdecode() fails if given a file that is not in xcode format or it +# the encoded file contains a record for which there is no declaration +# in the program in which the decoding is done. Of course, if a record +# is declared differently in the encoding and decoding programs, the +# decoding may be bogus. +# +# xencoden() and xdecoden() perform the same operations, except +# xencoden() and xdecoden() take the name of a file, not a file. +# +# xencodet() and xdecodet() are like xencode() and xdecode() +# except that the trailing argument is a type name. If the encoded +# decoded value is not of that type, they fail. xencodet() does +# not take an opt argument. +# +############################################################################ +# +# Complete calling sequences +# -------------------------- +# +# xencode(x, f, p) # returns f +# +# where +# +# x is the object to encode +# +# f is the file to write (default &output) +# +# p is a procedure that writes a line on f using the +# same interface as write() (the first parameter is +# always a the value passed as "file") (default: write) +# +# +# xencode(f, p) # returns the restored object +# +# where +# +# f is the file to read (default &input) +# +# p is a procedure that reads a line from f using the +# same interface as read() (the parameter is +# always a the value passed as "file") (default: read) +# +# +# The "p" parameter is not normally used for storage in text files, but +# it provides the flexibility to store the data in other ways, such as +# a string in memory. If "p" is provided, then "f" can be any +# arbitrary data object -- it need not be a file. +# +# For example, to "write" x to an Icon string: +# +# record StringFile(s) +# +# procedure main() +# ... +# encodeString := xencode(x,StringFile(""),WriteString).s +# ... +# end +# +# procedure WriteString(f,s[]) +# every f.s ||:= !s +# f.s ||:= "\n" +# return +# end +# +############################################################################ +# +# Notes on the encoding +# --------------------- +# +# Values are encoded as a sequence of one or more lines written to +# a plain text file. The first or only line of a value begins with a +# single character that unambiguously indicates its type. The +# remainder of the line, for some types, contains additional value +# information. Then, for some types, additional lines follow +# consisting of additional object encodings that further specify the +# object. The null value is a special case consisting of an empty +# line. +# +# Each object other than &null is assigned an integer tag as it is +# encoded. The tag is not, however, written to the output file. On +# input, tags are assigned in the same order as objects are decoded, so +# each restored object is associated with the same integer tag as it +# was when being written. In encoding, any recurrence of an object is +# represented by the original object's tag. Tag references are +# represented as integers, and are easily recognized since no object's +# representation begins with a digit. +# +# Where a structure contains elements, the encodings of the +# elements follow the structure's specification on following lines. +# Note that the form of the encoding contains the information needed to +# separate consecutive elements. +# +# Here are some examples of values and their encodings: +# +# x encode(x) +# ------------------------------------------------------- +# +# 1 N1 +# 2.0 N2.0 +# &null +# "\377" "\377" +# '\376\377' '\376\377' +# procedure main p +# "main" +# co-expression #1 (0) C +# [] L +# N0 +# set() "S" +# N0 +# table("a") T +# N0 +# "a" +# ["hi","there"] L +# N2 +# "hi" +# "there" +# +# A loop is illustrated by +# +# L2 := [] +# put(L2,L2) +# +# for which +# +# x encode(x) +# ------------------------------------------------------- +# +# L2 L +# N1 +# 2 +# +# The "2" on the third line is a tag referring to the list L2. The tag +# ordering specifies that an object is tagged *after* its describing +# objects, thus the list L2 has the tag 2 (the integer 1 has tag 1). +# +# Of course, you don't have to know all this to use xencode and +# xdecode. +# +############################################################################ +# +# Links: escape +# +############################################################################ +# +# See also: codeobj.icn +# +############################################################################ + +link escape + +record xcode_rec(file,ioProc,done,nextTag) + +procedure xencode(x,file,writeProc) #: write structure to file + + /file := &output + return xencode_1( + xcode_rec( + file, + (\writeProc | write) \ 1, + table(), + 0), + x) +end + +procedure xencode_1(data,x) + local tp,wr,f,im + wr := data.ioProc + f := data.file + # + # Special case for &null. + # + if /x then { + wr(f) + return f + } + # + # If this object has already been output, just write its tag. + # + if tp := \data.done[\x] then { + wr(f,tp) + return f + } + # + # Check to see if it's a "distinguished" that is represented by + # a keyword (special files and csets). If so, just use the keyword + # in the output. + # + im := image(x) + if match("integer(", im) then im := string(x) + else if match("&",im) then { + wr(f,im) + data.done[x] := data.nextTag +:= 1 + return f + } + # + # Determine the type and handle accordingly. + # + tp := case type(x) of { + "cset" | "string": "" + "file" | "window": "f" + "integer" | "real": "N" + "co-expression": "C" + "procedure": "p" + "list": "L" + "set": "S" + "table": "T" + default: "R" + } + case tp of { + # + # String, cset, or numeric outputs its string followed by its + # image. + # + "" | "N": wr(f,tp,im) + # + # Procedure writes "p" followed (on subsequent line) by its name + # as a string object. + # + "p": { + wr(f,tp) + im ? { + while tab(find(" ") + 1) + xencode_1(data,tab(0)) + } + } + # + # Co-expression, or file just outputs its letter. + # + !"CEf": wr(f,tp) + # + # Structured type outputs its letter followed (on subsequent + # lines) by additional data. A record writes its type as a + # string object; other type writes its size as an integer object. + # Structure elements follow on subsequent lines (alternating keys + # and values for tables). + # + default: { + wr(f,tp) + case tp of { + !"LST": { + im ? { + tab(find("(") + 1) + xencode_1(data,integer(tab(-1))) + } + if tp == "T" then xencode_1(data,x[[]]) + } + default: xencode_1(data, "record" || *x) # record -- fake it + } + # + # Create the tag. It's important that the tag is assigned + # *after* other other objects that describe this object (e.g. + # the length of a list) are output (and tagged), but *before* + # the structure elements; otherwise decoding would be + # difficult. + # + data.done[x] := data.nextTag +:= 1 + # + # Output the elements of the structure. + # + every xencode_1(data, + !case tp of {"S": sort(x); "T": sort(x,3); default: x}) + } + } + # + # Tag the object if it's not already tagged. + # + /data.done[x] := data.nextTag +:= 1 + return f +end + +procedure xdecode(file,readProc) #: read structure from file + + /file := &input + + return xdecode_1( + xcode_rec( + file, + (\readProc | read) \ 1, + [])) +end + +# This procedure fails if it encounters bad data + +procedure xdecode_1(data) + local x,tp,sz, i, s + data.ioProc(data.file) ? { + if any(&digits) then { + # + # It's a tag -- return its value from the object table. + # + return data.done[tab(0)] + } + if tp := move(1) then { + x := case tp of { + "N": numeric(tab(0)) + "\"": escape(tab(-1)) + "'": cset(escape(tab(-1))) + "p": proc(xdecode_1(data) | main) + "L": list(xdecode_1(data)) | stop("bad list") + "S": {sz := xdecode_1(data) | stop("bad set"); set()} + "T": {sz := xdecode_1(data) | stop("bad table"); table(xdecode_1(data)) | stop("bad table")} + "R": proc(s := xdecode_1(data))() | stop("*** bad record: ", image(s)) + "&": case tab(0) of { + # + # Special csets. + # + "cset": &cset + "ascii": &ascii + "digits": &digits + "letters": &letters + "lcase": &lcase + "ucase": &ucase + # + # Special files. + # + "input": &input + "output": &output + "errout": &errout + default: [] # so it won't crash if new keywords arise + } + "f": &input # to allow decoding + "C": &main # to allow decoding + default: stop("unknown type") + } + put(data.done,x) + case tp of { + !"LR": every i := 1 to *x do + x[i] := xdecode_1(data) | stop("bad list or record") + "T": every 1 to sz do + insert(x,xdecode_1(data),xdecode_1(data)) | fail + "S": every 1 to sz do + insert(x,xdecode_1(data)) | fail + } + return x + } + else return + } + +end + +procedure xencoden(x, name, opt) + local output + + /opt := "w" + + output := open(name, opt) | stop("*** xencoden(): cannot open ", name) + xencode(x, output) + close(output) + + return + +end + +procedure xencodet(x, file, typ) + + if type(x) === typ then return xencode(x, file) + else fail + +end + +procedure xdecodet(file, typ) + local x + + x := xdecode(file) + + if type(x) == typ then return x + else fail + +end + +procedure xdecoden(name) + local input, x + + input := open(name) | stop("*** xdecoden(): cannot open ", name) + if x := xdecode(input) then { + close(input) + return x + } + else { + close(input) + fail + } + +end diff --git a/ipl/procs/xforms.icn b/ipl/procs/xforms.icn new file mode 100644 index 0000000..96d973c --- /dev/null +++ b/ipl/procs/xforms.icn @@ -0,0 +1,117 @@ +############################################################################ +# +# File: xforms.icn +# +# Subject: Procedures to do matrix transformations +# +# Author: Stephen W. Wampler and Ralph E. Griswold +# +# Date: March 25, 2002 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These procedures produce matrices for affine transformation in two +# dimensions and transform point lists. +# +# A point list is a list of Point() records. See gobject.icn. +# +############################################################################ +# +# Links: matrix +# +############################################################################ + +link matrix + +procedure transform(p, M) #: transform point list by matrix + local pl, i + + # convert p to a matrix for matrix multiply... + + every put((pl := [[]])[1], (!p)|1.0) # the 1.0 makes it homogeneous + + # do the conversion... + + pl := mult_matrix(pl, M) + + # convert list back to a point list... + + p := copy(p) + every i := 1 to *p do + p[i] := pl[1][i] + + return p + +end + +procedure transform_points(pl,M) #: transform point list + local xformed + + every put(xformed := [], !transform(!pl,M)) + + return xformed + +end + +procedure set_scale(x, y) #: matrix for scaling + local M + + M := identity_matrix(3,3) + + M[1][1] := x + M[2][2] := y + + return M + +end + +procedure set_trans(x, y) #: matrix for translation + local M + + M := identity_matrix(3,3) + + M[*M][1] := x + M[*M][2] := y + + return M + +end + +procedure set_xshear(x) #: matrix for x shear + local M + + M := identity_matrix(3,3) + + M[1][2] := x + + return M + +end + +procedure set_yshear(y) #: matrix for y shear + local M + + M := identity_matrix(3,3) + + M[2][1] := y + + return M + +end + +procedure set_rotate(x) #: matrix for rotation + local M + + M := identity_matrix(3,3) + M[1][1] := cos(x) + M[2][2] := M[1][1] + M[1][2] := sin(x) + M[2][1] := -M[1][2] + + return M + +end diff --git a/ipl/procs/ximage.icn b/ipl/procs/ximage.icn new file mode 100644 index 0000000..e50ae1c --- /dev/null +++ b/ipl/procs/ximage.icn @@ -0,0 +1,209 @@ +############################################################################ +# +# File: ximage.icn +# +# Subject: Procedures to produce string image of structured data +# +# Author: Robert J. Alexander +# +# Date: May 19, 1996 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# ximage(x) : s +# +# Produces a string image of x. ximage() differs from image() in that +# it outputs all elements of structured data types. The output +# resembles Icon code and is thus familiar to Icon programmers. +# Additionally, it indents successive structural levels in such a way +# that it is easy to visualize the data's structure. Note that the +# additional arguments in the ximage procedure declaration are used for +# passing data among recursive levels. +# +# xdump(x1,x2,...,xn) : xn +# +# Using ximage(), successively writes the images of x1, x2, ..., xn to +# &errout. +# +# Some Examples: +# +# The following code: +# ... +# t := table() ; t["one"] := 1 ; t["two"] := 2 +# xdump("A table",t) +# xdump("A list",[3,1,3,[2,4,6],3,4,3,5]) +# +# Writes the following output (note that ximage() infers the +# predominant list element value and avoids excessive output): +# +# "A table" +# T18 := table(&null) +# T18["one"] := 1 +# T18["two"] := 2 +# "A list" +# L25 := list(8,3) +# L25[2] := 1 +# L25[4] := L24 := list(3) +# L24[1] := 2 +# L24[2] := 4 +# L24[3] := 6 +# L25[6] := 4 +# L25[8] := 5 +# + + +procedure ximage(x,indent,done) #: string image of value + local i,s,ss,state,t,xtag,tp,sn,sz + static tr, name + + initial name := proc("name", 0) # REG: in case name is a global + + # + # If this is the outer invocation, do some initialization. + # + if /(state := done) then { + tr := &trace ; &trace := 0 # postpone tracing while in here + indent := "" + done := table() + } + # + # Determine the type and process accordingly. + # + indent := (if indent == "" then "\n" else "") || indent || " " + ss := "" + tp := type(x) + s := if xtag := \done[x] then xtag else case tp of { + # + # Unstructured types just return their image(). + # + "integer": x + "null" | "string" | "real" | "cset" | "window" | + "co-expression" | "file" | "procedure" | "external": image(x) + # + # List. + # + "list": { + image(x) ? { + tab(6) + sn := tab(find("(")) + sz := tab(0) + } + done[x] := xtag := "L" || sn + # + # Figure out if there is a predominance of any object in the + # list. If so, make it the default object. + # + t := table(0) + every t[!x] +:= 1 + s := [,0] + every t := !sort(t) do if s[2] < t[2] then s := t + if s[2] > *x / 3 & s[2] > 2 then { + s := s[1] + t := ximage(s,indent || " ",done) + if t ? (not any('\'"') & ss := tab(find(" :="))) then + t := "{" || t || indent || " " || ss || "}" + } + else s := t := &null + # + # Output the non-defaulted elements of the list. + # + ss := "" + every i := 1 to *x do if x[i] ~=== s then { + ss ||:= indent || xtag || "[" || i || "] := " || + ximage(x[i],indent,done) + } + s := tp || sz + s[-1:-1] := "," || \t + xtag || " := " || s || ss + } + # + # Set. + # + "set": { + image(x) ? { + tab(5) + sn := tab(find("(")) + } + done[x] := xtag := "S" || sn + every i := !sort(x) do { + t := ximage(i,indent || " ",done) + if t ? (not any('\'"') & s := tab(find(" :="))) then + t := "{" || t || indent || " " || s || "}" + ss ||:= indent || "insert(" || xtag || "," || t || ")" + } + xtag || " := " || "set()" || ss + } + # + # Table. + # + "table": { + image(x) ? { + tab(7) + sn := tab(find("(")) + } + done[x] := xtag := "T" || sn + # + # Output the table elements. This is a bit tricky, since + # the subscripts might be structured, too. + # + every i := !sort(x) do { + t := ximage(i[1],indent || " ",done) + if t ? (not any('\'"') & s := tab(find(" :="))) then + t := "{" || t || indent || " " || s || "}" + ss ||:= indent || xtag || "[" || + t || "] := " || + ximage(i[2],indent,done) + } + # + # Output the table, including its default value (which might + # also be structured). + # + t := ximage(x[[]],indent || " ",done) + if t ? (not any('\'"') & s := tab(find(" :="))) then + t := "{" || t || indent || " " || s || "}" + xtag || " := " || "table(" || t || ")" || ss + } + # + # Record. + # + default: { + image(x) ? { + move(7) + t := "" + while t ||:= tab(find("_")) || move(1) + t[-1] := "" + sn := tab(find("(")) + } + done[x] := xtag := "R_" || t || "_" || sn + every i := 1 to *x do { + name(x[i]) ? (tab(find(".")),sn := tab(0)) + ss ||:= indent || xtag || sn || " := " || + ximage(\x[i],indent,done) + } + xtag || " := " || t || "()" || ss + } + } + # + # If this is the outer invocation, clean up before returning. + # + if /state then { + &trace := tr # restore &trace + } + # + # Return the result. + # + return s +end + + +# +# Write ximages of x1,x1,...,xn. +# +procedure xdump(x[]) #: write images of values + every write(&errout,ximage(!x)) + return x[-1] | &null +end diff --git a/ipl/procs/xrotate.icn b/ipl/procs/xrotate.icn new file mode 100644 index 0000000..6070390 --- /dev/null +++ b/ipl/procs/xrotate.icn @@ -0,0 +1,38 @@ +############################################################################ +# +# File: xrotate.icn +# +# Subject: Procedure to rotate values in list or record +# +# Author: Ralph E. Griswold +# +# Date: April 30, 1993 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# xrotate(X, i) rotates the values in X right by one position. It works +# for lists and records. +# +# This procedure is mainly interesting as a recursive version of +# +# x1 :=: x2 :=: x3 :=: ... xn +# +# since a better method for lists is +# +# push(L, pull(L)) +# +############################################################################ + +procedure xrotate(X, i) + + /i := 1 + + X[i] :=: xrotate(X, i + 1) + + return X[i] + +end diff --git a/ipl/procs/zipread.icn b/ipl/procs/zipread.icn new file mode 100644 index 0000000..a1be108 --- /dev/null +++ b/ipl/procs/zipread.icn @@ -0,0 +1,75 @@ +############################################################################ +# +# File: zipread.icn +# +# Subject: Procedures for reading files from ZIP archives +# +# Author: Gregg M. Townsend +# +# Date: March 5, 2000 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These Unix procedures read files from ZIP format archives by +# opening pipes to the "unzip" utility. It is assumed that +# "unzip" is in the shell search path. +# +# iszip(zname) succeeds if zname is a ZIP archive. +# zipdir(zname) opens a ZIP archive directory. +# zipfile(zname, fname) opens a member of a ZIP archive. +# +############################################################################ +# +# iszip(zname) succeeds if the named file appears to be +# a ZIP format archive file. +# +############################################################################ +# +# zipdir(zname) returns a pipe from which the members of the +# ZIP archive can be read, one per line, as if reading a +# directory. It is assumed that zname is a ZIP archive. +# +############################################################################ +# +# zipfile(zname, fname) returns a pipe from which the +# file fname within the ZIP archive zname can be read. +# It is assumed that zname and fname are valid. +# +############################################################################ +# +# Requires: UNIX with "unzip" utility. +# +############################################################################ + + + +# iszip(zname) -- succeed if zname is a ZIP archive file + +procedure iszip(fname) #: check for ZIP archive + local f, s + + f := open(fname, "ru") | fail + s := reads(f, 4) + close(f) + return s === "PK\03\04" +end + + + +# zipdir(zname) -- returns a file representing the ZIP directory + +procedure zipdir(zname) #: open ZIP directory + return open("unzip -l " || zname || " | sed -n 's/.*:.. //p'", "rp") +end + + + +# zipfile(zname, fname) -- open file fname inside archive zname + +procedure zipfile(zname, fname) #: open member of ZIP archive + return open("unzip -p " || zname || " " || fname, "rp") +end |