#
#          D E F I N E D   C O N T R O L   O P E R A T I O N S
#

#  This program illustrates how programmer-control operations can be
#  implemented in Icon using co-expressions and the p{ ... }
#  syntax that facilitates their use.

procedure main()
   if not(&features == "co-expressions") then
      stop("co-expressions not supported")
   write(Seqimage{1 to 10})
   write(Seqimage{&fail})
   write(Seqimage{(1 to 10 by 2) | (10 to 1 by -2)})
   write(Seqimage{!"abc" || !"xy"})
   write(Seqimage{Seqimage | main})
   every write(Galt{1 to 10,!"abcd",1 to 10})
   write(Seqimage{star("abc") \ 10})
   write(Seqimage{1 to 50,5})
   write("---")
   every write(Limit{1 to 100,3})
   write("---")
   every write(Ranseq{!"abcd",1 to 10})
   every Parallel{|write,!"abcd",1 to 10}
   every Allpar{|write,!"abcd",1 to 10} \ 20
   every Rotate{|write,!"abcd",1 to 10} \ 20
end

procedure star(s)
   suspend "" | (star(s) || !s)
end

procedure Galt(a)
   local e
   every e := !a do suspend |@e
end

procedure Limit(a)
   local i, x
   while i := @a[2] do {
      a[1] := ^a[1]
      every 1 to i do
         if x := @a[1] then suspend x
         else break
      }
end

procedure Ranseq(a)
   local x
   while x := @?a do suspend x
end

procedure Seqimage(L)
   local s
   s := ""
   while s ||:= ", " || image(@L[1])
   return "{" || s[3:0] || "}" | "{}"
end

procedure Allpar(a)
   local i, x, done
   x := list(*a)
   done := list(*a,1)
   every i := 1 to *a do x[i] := @a[i] | fail
   repeat {
      suspend Call(x)
      every i := 1 to *a do
         if done[i] = 1 then ((x[i] := @a[i]) | (done[i] := 0))
      if not(!done = 1) then fail
       }
end

procedure Call(a)
   suspend case *a of {
      1 : a[1]()
      2 : a[1](a[2])
      3 : a[1](a[2],a[3])
      4 : a[1](a[2],a[3],a[4])
      5 : a[1](a[2],a[3],a[4],a[5])
      6 : a[1](a[2],a[3],a[4],a[5],a[6])
      7 : a[1](a[2],a[3],a[4],a[5],a[6],a[7])
      8 : a[1](a[2],a[3],a[4],a[5],a[6],a[7],a[8])
      9 : a[1](a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9])
      10 : a[1](a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],a[10])
      default :  stop("Call : too many args.")
      }
end

procedure Extract(a)
   local i, j, n, x
   x := list(*a/2)
   repeat {
      i := 1
      while i < *a do {
         n := @a[i] | fail
         every 1 to n do
            x[(i + 1)/2] := @a[i + 1] | fail
         a[i + 1] := ^a[i + 1]
         i +:= 2
         }
      suspend Call(x)
      }
end

procedure Lifo(a)
   local i, x, ptr
   x := list(*a)
   ptr := 1
   repeat {
      repeat
         if x[ptr] := @a[ptr]
         then {
            ptr +:= 1
            (a[ptr] := ^a[ptr]) |
            break
            }
         else if (ptr -:=  1) = 0
              then fail
      suspend Call(x)
      ptr := *a
      }
end

procedure Parallel(a)
   local i, x
   x := list(*a)
   repeat {
      every i := 1 to *a do
         x[i] := @a[i] | fail
      suspend Call(x)
      }
end

procedure Reverse(a)
   local i, x, ptr
   x := list(*a)
   ptr := *a
   repeat {
      repeat
         if x[ptr] := @a[ptr]
         then {
            ptr -:= 1
            (a[ptr] := ^a[ptr]) |
            break
            }
         else if (ptr +:= 1) > *a
              then fail
      suspend Call(x)
      ptr := 1
      }
end

procedure Rotate(a)
   local i, x, done
   x := list(*a)
   done := list(*a,1)
   every i := 1 to *a do x[i] := @a[i] | fail
   repeat {
      suspend Call(x)
      every i := 1 to *a do
         if not(x[i] := @a[i]) then {
            done[i] := 0
            if !done = 1 then {
               a[i] := ^a[i]
               x[i] := @a[i] | fail
               }
            else fail
            }
        }
end

procedure Simple(a)
   local i, x
   x := list(*a)
   every i := 1 to *a do
      x[i] := @a[i] | fail
   return Call(x)
end