############################################################################
#
#	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
