diff options
Diffstat (limited to 'ipl/procs/pdco.icn')
| -rw-r--r-- | ipl/procs/pdco.icn | 1197 |
1 files changed, 1197 insertions, 0 deletions
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 |