adamc@915: datatype dlist'' t =
adamc@915:          Nil
adamc@915:        | Cons of t * source (dlist'' t)
adamc@915: 
adamc@915: datatype dlist' t =
adamc@915:          Empty
adamc@915:        | Nonempty of { Head : dlist'' t, Tail : source (source (dlist'' t)) }
adamc@915: 
adamc@951: con dlist t = source (dlist' t)
adamc@915: 
adamc@915: type position = transaction unit
adamc@915: 
adamc@915: fun headPos [t] (dl : dlist t) =
adamc@951:     dl' <- get dl;
adamc@915:     case dl' of
adamc@915:         Nonempty { Head = Cons (_, tl), Tail = tl' } =>
adamc@915:         cur <- get tl;
adamc@951:         set dl (case cur of
adamc@951:                     Nil => Empty
adamc@951:                   | _ => Nonempty {Head = cur, Tail = tl'})
adamc@915:       | _ => return ()
adamc@915: 
adamc@915: fun tailPos [t] (cur : source (dlist'' t)) new tail =
adamc@915:     new' <- get new;
adamc@915:     set cur new';
adamc@915: 
adamc@915:     case new' of
adamc@915:         Nil => set tail cur
adamc@915:       | _ => return ()
adamc@915: 
adamc@951: val create [t] = source Empty
adamc@915: 
adamc@951: fun clear [t] (s : dlist t) = set s Empty
adamc@915: 
adamc@915: fun append [t] dl v =
adamc@951:     dl' <- get dl;
adamc@915:     case dl' of
adamc@915:         Empty =>
adamc@915:         tl <- source Nil;
adamc@915:         tl' <- source tl;
adamc@951:         set dl (Nonempty {Head = Cons (v, tl), Tail = tl'});
adamc@915:         return (headPos dl)
adamc@915:                 
adamc@915:       | Nonempty {Tail = tl, ...} =>
adamc@915:         cur <- get tl;
adamc@915:         new <- source Nil;
adamc@915:         set cur (Cons (v, new));
adamc@915:         set tl new;
adamc@915:         return (tailPos cur new tl)
adamc@915: 
adamc@954: fun replace [t] dl ls =
adamc@954:     case ls of
adamc@954:         [] => set dl Empty
adamc@954:       | x :: ls =>
adamc@954:         tl <- source Nil;
adamc@954:         let
adamc@954:             fun build ls acc =
adamc@954:                 case ls of
adamc@954:                     [] => return acc
adamc@954:                   | x :: ls =>
adamc@957:                     this <- source (Cons (x, acc));
adamc@954:                     build ls this
adamc@954:         in
adamc@954:             hd <- build (List.rev ls) tl;
adamc@954:             tlS <- source tl;
adamc@954:             set dl (Nonempty {Head = Cons (x, hd), Tail = tlS})
adamc@954:         end
adamc@954: 
adamc@963: fun renderDyn [ctx] [ctx ~ body] [t] (f : t -> position -> xml (ctx ++ body) [] []) filter pos len dl = <xml>
adamc@951:   <dyn signal={dl' <- signal dl;
adamc@962:                case dl' of
adamc@962:                    Empty => return <xml/>
adamc@962:                  | Nonempty {Head = hd, Tail = tlTop} => 
adamc@962:                    let
adamc@963:                        fun render' prev dl'' len =
adamc@963:                            case len of
adamc@963:                                Some 0 => <xml/>
adamc@963:                              | _ =>
adamc@963:                                case dl'' of
adamc@963:                                    Nil => <xml/>
adamc@963:                                  | Cons (v, tl) =>
adamc@963:                                    let
adamc@963:                                        val pos = case prev of
adamc@963:                                                      None => headPos dl
adamc@963:                                                    | Some prev => tailPos prev tl tlTop
adamc@963:                                    in
adamc@966:                                        <xml>
adamc@966:                                          <dyn signal={b <- filter v;
adamc@966:                                                       return <xml>
adamc@966:                                                         {if b then
adamc@966:                                                              f v pos
adamc@966:                                                          else
adamc@966:                                                              <xml/>}
adamc@966:                                                         <dyn signal={tl' <- signal tl;
adamc@966:                                                                      return (render' (Some tl) tl'
adamc@966:                                                                                      (if b then
adamc@966:                                                                                           Option.mp (fn n => n - 1) len
adamc@966:                                                                                       else
adamc@966:                                                                                           len))}/>
adamc@966:                                                       </xml>}/>
adamc@966:                                        </xml>
adamc@963:                                    end
adamc@962: 
adamc@962:                        fun skip pos hd =
adamc@962:                            case pos of
adamc@962:                                0 => return hd
adamc@962:                              | _ =>
adamc@962:                                case hd of
adamc@962:                                    Nil => return hd
adamc@962:                                  | Cons (_, tl) =>
adamc@962:                                    tl' <- signal tl;
adamc@962:                                    skip (pos-1) tl'
adamc@962:                    in
adamc@962:                        case pos of
adamc@963:                            None => return (render' None hd len)
adamc@962:                          | Some pos =>
adamc@962:                            hd <- skip pos hd;
adamc@963:                            return (render' None hd len)
adamc@962:                    end}/>
adamc@915: </xml>
adamc@915: 
adam@1304: fun renderFlat [ctx] [ctx ~ body] [t] (f : t -> position -> xml (ctx ++ body) [] [])
adam@1304:     : option int -> list (t * position) -> xml (ctx ++ body) [] [] =
adamc@963:     let
adamc@963:         fun renderFlat' len ls =
adamc@963:             case len of
adamc@963:                 Some 0 => <xml/>
adamc@963:               | _ =>
adamc@963:                 case ls of
adamc@963:                     [] => <xml/>
adamc@963:                   | p :: ls =>
adamc@963:                     let
adamc@963:                         val len =
adamc@963:                             case len of
adamc@963:                                 None => None
adamc@963:                               | Some n => Some (n - 1)
adamc@963:                     in
adamc@963:                         <xml>{f p.1 p.2}{renderFlat' len ls}</xml>
adamc@963:                     end
adamc@963:     in
adamc@963:         renderFlat'
adamc@963:     end
adamc@952: 
adamc@953: val split [t] =
adamc@953:     let
adamc@953:         fun split' acc (ls : list t) =
adamc@953:             case ls of
adamc@953:                 [] => acc
adamc@953:               | x1 :: [] => (x1 :: acc.1, acc.2)
adamc@953:               | x1 :: x2 :: ls => split' (x1 :: acc.1, x2 :: acc.2) ls
adamc@953:     in
adamc@953:         split' ([], [])
adamc@953:     end
adamc@953: 
adamc@953: fun merge [t] (cmp : t -> t -> signal bool) =
adamc@953:     let
adamc@953:         fun merge' acc (ls1 : list t) (ls2 : list t) =
adamc@953:             case (ls1, ls2) of
adamc@953:                 ([], _) => return (List.revAppend acc ls2)
adamc@953:               | (_, []) => return (List.revAppend acc ls1)
adamc@953:               | (x1 :: ls1', x2 :: ls2') =>
adamc@953:                 b <- cmp x1 x2;
adamc@953:                 if b then
adamc@953:                     merge' (x1 :: acc) ls1' ls2
adamc@953:                 else
adamc@953:                     merge' (x2 :: acc) ls1 ls2'
adamc@953:     in
adamc@953:         merge' []
adamc@953:     end
adamc@953: 
adamc@953: fun sort [t] (cmp : t -> t -> signal bool) =
adamc@953:     let
adamc@953:         fun sort' (ls : list t) =
adamc@953:             case ls of
adamc@953:                 [] => return ls
adamc@953:               | _ :: [] => return ls
adamc@953:               | _ =>
adamc@953:                 let
adamc@953:                     val (ls1, ls2) = split ls
adamc@953:                 in
adamc@953:                     ls1' <- sort' ls1;
adamc@953:                     ls2' <- sort' ls2;
adamc@953:                     merge cmp ls1' ls2'
adamc@953:                 end
adamc@953:     in
adamc@953:         sort'
adamc@953:     end
adamc@953: 
adamc@953: fun render [ctx] [ctx ~ body] [t] f (r : {Filter : t -> signal bool,
adamc@962:                                           Sort : signal (option (t -> t -> signal bool)),
adamc@963:                                           StartPosition : signal (option int),
adamc@963:                                           MaxLength : signal (option int)}) dl = <xml>
adamc@963:     <dyn signal={len <- r.MaxLength;
adamc@963:                  cmp <- r.Sort;
adamc@962:                  pos <- r.StartPosition;
adamc@963: 
adamc@953:                  case cmp of
adamc@963:                      None => return (renderDyn f r.Filter pos len dl)
adamc@953:                    | Some cmp =>
adamc@952:                      dl' <- signal dl;
adamc@952:                      elems <- (case dl' of
adamc@952:                                    Empty => return []
adamc@952:                                  | Nonempty {Head = hd, Tail = tlTop} =>
adamc@952:                                    let
adamc@952:                                        fun listOut prev dl'' acc =
adamc@952:                                            case dl'' of
adamc@952:                                                Nil => return acc
adamc@952:                                              | Cons (v, tl) =>
adamc@952:                                                let
adamc@952:                                                    val pos = case prev of
adamc@952:                                                                  None => headPos dl
adamc@952:                                                                | Some prev => tailPos prev tl tlTop
adamc@952:                                                in
adamc@958:                                                    b <- r.Filter v;
adamc@952:                                                    tl' <- signal tl;
adamc@958:                                                    listOut (Some tl) tl' (if b then
adamc@958:                                                                               (v, pos) :: acc
adamc@958:                                                                           else
adamc@958:                                                                               acc)
adamc@952:                                                end
adamc@952:                                    in
adamc@952:                                        listOut None hd []
adamc@952:                                    end);
adamc@953:                      elems <- sort (fn v1 v2 => cmp v1.1 v2.1) elems;
adamc@962:                      let
adamc@962:                          fun skip n ls =
adamc@962:                              case (n, ls) of
adamc@962:                                  (0, _) => ls
adamc@962:                                | (n, _ :: ls) => skip (n-1) ls
adamc@962:                                | (_, []) => []
adamc@962: 
adamc@962:                          val elems =
adamc@962:                              case pos of
adamc@962:                                  None => elems
adamc@962:                                | Some pos => skip pos elems
adamc@962:                      in
adam@1304:                          return (renderFlat f len elems)
adamc@962:                      end}/>
adamc@952: </xml>
adamc@952: 
adamc@915: fun delete pos = pos
adamc@915: 
adam@1304: fun elements' [t] (dl'' : dlist'' t) : signal (list t) =
adamc@915:     case dl'' of
adamc@915:         Nil => return []
adamc@915:       | Cons (x, dl'') =>
adamc@915:         dl'' <- signal dl'';
adamc@915:         tl <- elements' dl'';
adamc@915:         return (x :: tl)
adamc@915: 
adam@1304: fun elements [t] (dl : dlist t) : signal (list t) =
adamc@951:     dl' <- signal dl;
adamc@915:     case dl' of
adamc@915:         Empty => return []
adamc@915:       | Nonempty {Head = hd, ...} => elements' hd
adamc@937: 
adam@1304: fun size' [t] (dl'' : dlist'' t) : signal int =
adamc@964:     case dl'' of
adamc@964:         Nil => return 0
adamc@964:       | Cons (x, dl'') =>
adamc@964:         dl'' <- signal dl'';
adamc@964:         n <- size' dl'';
adamc@964:         return (n + 1)
adamc@964: 
adam@1304: fun size [t] (dl : dlist t) : signal int =
adamc@964:     dl' <- signal dl;
adamc@964:     case dl' of
adamc@964:         Empty => return 0
adamc@964:       | Nonempty {Head = hd, ...} => size' hd
adamc@964: 
adam@1304: fun numPassing' [t] (f : t -> signal bool) (dl'' : dlist'' t) : signal int =
adamc@965:     case dl'' of
adamc@965:         Nil => return 0
adamc@965:       | Cons (x, dl'') =>
adamc@965:         b <- f x;
adamc@965:         dl'' <- signal dl'';
adamc@965:         n <- numPassing' f dl'';
adamc@965:         return (if b then n + 1 else n)
adamc@965: 
adam@1304: fun numPassing [t] (f : t -> signal bool) (dl : dlist t) : signal int =
adamc@965:     dl' <- signal dl;
adamc@965:     case dl' of
adamc@965:         Empty => return 0
adamc@965:       | Nonempty {Head = hd, ...} => numPassing' f hd
adamc@965: 
adamc@937: fun foldl [t] [acc] (f : t -> acc -> signal acc) =
adamc@937:     let
adamc@937:         fun foldl'' (i : acc) (dl : dlist'' t) : signal acc =
adamc@937:             case dl of
adamc@937:                 Nil => return i
adamc@937:               | Cons (v, dl') =>
adamc@937:                 dl' <- signal dl';
adamc@937:                 i' <- f v i;
adamc@937:                 foldl'' i' dl'
adamc@937: 
adamc@937:         fun foldl' (i : acc) (dl : dlist t) : signal acc =
adamc@951:             dl <- signal dl;
adamc@937:             case dl of
adamc@937:                 Empty => return i
adamc@937:               | Nonempty {Head = dl, ...} => foldl'' i dl
adamc@937:     in
adamc@937:         foldl'
adamc@937:     end