############################################################################
#
# File: pdco.icn
#
# Subject: Procedures for programmer-defined control operations
#
# Authors: Ralph E. Griswold and Robert J. Alexander
#
# Date: June 10, 2001
#
############################################################################
#
# 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 e1-th terms from e2
#
# 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 * j 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
#
# 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 evuation 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 limtation
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 sequneces
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 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
This page produced by UniDoc on 2021/04/15 @ 23:59:44.