(*---------------------------------------------------------------------------*
  IMPLEMENTATION  cf_flow.ml

  Copyright (c) 2002-2006, James H. Woodyatt
  All rights reserved.

  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions
  are met:

    Redistributions of source code must retain the above copyright
    notice, this list of conditions and the following disclaimer.

    Redistributions in binary form must reproduce the above copyright
    notice, this list of conditions and the following disclaimer in
    the documentation and/or other materials provided with the
    distribution

  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
  OF THE POSSIBILITY OF SUCH DAMAGE. 
 *---------------------------------------------------------------------------*)

type ('i, 'o) t = ('i, 'o) cell Lazy.t
and ('i, 'o) cell = P of 'o * ('i,'o) t | Q of ('i -> ('i, 'o) cell) | Z

let nil = lazy Z

let rec nop = lazy (Q (fun x -> P (x, nop)))

let rec filter f =
    let rec loop x = if f x then P (x, filter f) else Q loop in
    Lazy.lazy_from_val (Q loop)

let rec map f = Lazy.lazy_from_val (Q (fun x -> P (f x, map f)))

let rec optmap f =
    let rec loop x =
        match f x with
        | Some y -> P (y, optmap f)
        | None -> Q loop
    in
    Lazy.lazy_from_val (Q loop)

let rec listmap f =
    let rec outer x = inner (listmap f) (f x)
    and inner w = function
        | hd :: tl -> P (hd, lazy (inner w tl))
        | [] -> Lazy.force w
    in
    Lazy.lazy_from_val (Q outer)

let rec put_seq_ w s =
    match Lazy.force s with
    | Cf_seq.P (hd, tl) -> P (hd, lazy (put_seq_ w tl))
    | Cf_seq.Z -> Lazy.force w

let rec seqmap f =
    let rec loop x = put_seq_ (seqmap f) (f x) in
    Lazy.lazy_from_val (Q loop)

let broadcast =
    let rec loop fs = function
        | hd :: tl ->
            begin
                match Lazy.force hd with
                | Z -> loop fs tl
                | P (y, next) -> P (y, lazy (loop fs (next :: tl)))
                | Q f -> loop (f :: fs) tl
            end
        | [] ->
            match fs with
            | [] ->
                Z
            | fs ->
                Q (fun x -> loop [] (List.rev_map (fun f -> lazy (f x)) fs))
    in
    fun ws -> lazy (loop [] ws)

let rec mapstate f s =
    lazy (Q (fun x -> let s, y = f s x in P (y, mapstate f s)))

let rec machine f =
    let loop s x =
        match f s x with
        | Some (s, out) -> put_seq_ (machine f s) out
        | None -> Z
    in
    fun s -> lazy (Q (loop s))

module Op = struct
    let ( -*- ) =
        let rec loop w1 w2 =
            match Lazy.force w1 with
            | Z -> Lazy.force w2
            | P (hd, tl) -> P (hd, lazy (loop tl w2))
            | Q f1 as w1cell ->
                match Lazy.force w2 with
                | Z -> w1cell
                | P (hd, tl) -> P (hd, lazy (loop w1 tl))
                | Q f2 -> Q begin fun x ->
                    let w1 = Lazy.lazy_from_val (f1 x) in
                    let w2 = lazy (f2 x) in
                    loop w1 w2
                end
        in
        fun w1 w2 ->
            lazy (loop w1 w2)
    
    let ( -=- ) =
        let rec loop w1 w2 =
            match Lazy.force w2 with
            | Z -> Z
            | P (hd, tl) -> P (hd, lazy (loop w1 tl))
            | Q f ->
                match Lazy.force w1 with
                | Z -> Z
                | P (hd, tl) -> loop tl (lazy (f hd))
                | Q f -> Q (fun x -> loop (Lazy.lazy_from_val (f x)) w2)
        in
        fun w1 w2 ->
            lazy (loop w1 w2)

    let ( -&- ) =
        let rec loop w1 w2 =
            match Lazy.force w1 with
            | Z -> Lazy.force w2
            | P (hd, tl) -> P (hd, lazy (loop tl w2))
            | Q f -> Q (fun x -> loop (Lazy.lazy_from_val (f x)) w2)
        in
        fun w1 w2 ->
            lazy (loop w1 w2)
    
    let rec ( ~@ ) =
        let rec loop q w =
            match Lazy.force w with
            | Z -> Z
            | P (hd, tl) -> P (hd, lazy (loop (Cf_deque.A.push hd q) tl))
            | Q f ->
                match Cf_deque.B.pop q with
                | Some (hd, tl) -> loop tl (Lazy.lazy_from_val (f hd))
                | None -> Q (fun x -> loop q (lazy (f x)))
        in
        fun w ->
            lazy (loop Cf_deque.nil w)

    let consA_ a = Cf_either.A a
    let consB_ b = Cf_either.B b
    let stripA_ = function Cf_either.A a -> Some a | _ -> None
    let stripB_ = function Cf_either.B b -> Some b | _ -> None

    let ( -+- ) s0 s1 =
        let s0 = optmap stripA_ -=- s0 -=- map consA_ 
        and s1 = optmap stripB_ -=- s1 -=- map consB_
        in s0 -*- s1

    let stripBorAA_ = function
        | Cf_either.B _ as v
        | Cf_either.A (Cf_either.A _ as v) -> Some v
        | _ -> None
    
    let stripAB_ = function
        | Cf_either.A (Cf_either.B x) -> Some x
        | _ -> None
 
    let ( ~@< ) s =
        let s' = optmap stripBorAA_ -=- s -=- map consA_ in
        map consB_ -=- ~@ s' -=- optmap stripAB_

    let pre_ = function
        | Cf_either.B x -> Cf_either.B (Cf_either.B x)
        | Cf_either.A (Cf_either.A x) -> Cf_either.A x
        | Cf_either.A (Cf_either.B x) -> Cf_either.B (Cf_either.A x)
    
    let post_ = function
        | Cf_either.B (Cf_either.B x) -> Cf_either.B x
        | Cf_either.B (Cf_either.A x) -> Cf_either.A (Cf_either.A x)
        | Cf_either.A x -> Cf_either.A (Cf_either.B x)

    let ( -@- ) s1 s0 = ~@< (map pre_ -=- (s0 -+- s1) -=- map post_)
end

open Op

let to_seq =
    let rec loop w =
        match Lazy.force w with
        | Z -> Cf_seq.Z
        | P (hd, tl) -> Cf_seq.P (hd, lazy (loop tl))
        | Q f -> loop (lazy (f ()))
    in
    fun w -> lazy (loop w)

let of_seq =
    let rec loop s =
        match Lazy.force s with
        | Cf_seq.P (hd, tl) -> P (hd, lazy (loop tl))
        | Cf_seq.Z -> Z
    in
    fun s -> lazy (loop s)

let delta_ = (int_of_char 'a') - (int_of_char 'A')

let upcase =
    map begin function
        | 'a'..'z' as c -> char_of_int ((int_of_char c) - delta_)
        | c -> c
    end

let dncase =
    map begin function
        | 'A'..'Z' as c -> char_of_int ((int_of_char c) + delta_)
        | c -> c
    end

let rec commute =
    let rec loop w s =
        match Lazy.force w with
        | Z -> Cf_seq.Z
        | P (hd, tl) -> Cf_seq.P (hd, commute tl s)
        | Q f ->
            match Lazy.force s with
            | Cf_seq.P (hd, tl) -> loop (Lazy.lazy_from_val (f hd)) tl
            | Cf_seq.Z -> Cf_seq.Z
    in
    fun w s ->
        lazy (loop w s)

let commute_string w s = Cf_seq.to_string (commute w (Cf_seq.of_string s))

let drain =
    let rec loop w =
        match Lazy.force w with
        | P (hd, tl) -> Cf_seq.P (hd, lazy (loop tl))
        | _ -> Cf_seq.Z
    in
    fun w -> lazy (loop w)

let flush =
    let rec loop w =
        match Lazy.force w with
        | P (_, tl) -> loop tl
        | w -> w
    in
    fun w -> lazy (loop w)

let rec ingestor =
    let rec loop = function
        | None -> Z
        | Some s ->
            match Lazy.force s with
            | Cf_seq.Z -> Q loop
            | Cf_seq.P (hd, tl) -> P (hd, lazy (loop (Some tl)))
    in
    lazy (Q loop)

let rec transcode_drain_ w =
    match Lazy.force w with
    | Z -> Cf_seq.Z
    | P (hd, tl) -> Cf_seq.P (hd, lazy (transcode_drain_ tl))
    | Q f -> transcode_drain_ (lazy (f None))

let transcode =
    let rec loop (w : ('i Cf_seq.t option, 'o) t) (s : 'i Cf_seq.t) =
        match Lazy.force w with
        | Z -> Cf_seq.Z
        | P (hd, tl) -> Cf_seq.P (hd, lazy (loop tl s))
        | Q f -> transcode_drain_ (lazy (f (Some s)))
    in
    fun w s ->
        lazy (loop w s)

module Transcode = struct
    let more w s =
        match Lazy.force w with
        | Z -> Cf_seq.nil, w
        | P (_, _) -> drain w, flush w
        | Q f -> let w = lazy (f (Some s)) in drain w, flush w
    
    let last w =
        match Lazy.force w with
        | Z -> Cf_seq.nil
        | P (_, _) -> drain w
        | Q f -> drain (lazy (f None))
end

let finishC_ _ = Lazy.lazy_from_val Z
let finishSC_ _ _ = Lazy.lazy_from_val Z

let readC f = lazy (Q (fun a -> Lazy.force (f a)))
let writeC o f = lazy (P (o, f ()))
let evalC m = m finishC_

let readSC f s = lazy (Q (fun a -> Lazy.force (f a s)))
let writeSC o f s = lazy (P (o, f () s))
let evalSC m s = m finishSC_ s

(*--- End of File [ cf_flow.ml ] ---*)
