1structure stringfindreplace :> stringfindreplace =
2struct
3
4datatype 'a trie = Nd of 'a option * (char, 'a trie) Binarymap.dict
5
6fun dictOf (Nd(_, d)) = d
7fun valueOf (Nd(v,_)) = v
8
9fun empty() = Nd (NONE, Binarymap.mkDict Char.compare)
10
11fun insert (t, s, v) =
12  let
13    fun recurse t ss =
14      let
15        val Nd (val0, dict) = t
16      in
17        case Substring.getc ss of
18            NONE => Nd(SOME v, dict)
19          | SOME (c, ss') =>
20            let
21              val subt = case Binarymap.peek(dict, c) of
22                             NONE => empty()
23                           | SOME t => t
24            in
25              Nd(val0, Binarymap.insert(dict,c,recurse subt ss'))
26            end
27      end
28  in
29    recurse t (Substring.full s)
30  end
31
32fun foldl f acc t =
33  let
34    fun recurse k acc0 t =
35      let
36        val acc = case valueOf t of
37                      NONE => acc0
38                    | SOME v => f(k,v,acc0)
39      in
40        Binarymap.foldl (fn (c,t,a) => recurse (k ^ str c) a t) acc (dictOf t)
41      end
42  in
43    recurse "" acc t
44  end
45
46fun final_replacement s imaps =
47  case imaps of
48      [] => s
49    | (i, (repl, numtoremove)) :: rest =>
50      let
51        val _ = i >= 0 orelse raise Fail "Negative index in alist"
52        val resti = i + numtoremove
53      in
54        String.extract(s,0, SOME i) ^ repl ^
55        final_replacement (String.extract(s, resti, NONE))
56                          (map (fn (i,v) => (i - resti, v)) rest)
57      end
58
59fun foldcheck trie0 s =
60  let
61    val sz = size s
62    fun onestep i done cont k =
63      (*
64         cont is a map (alist) from indexes into the string to a pair of
65         a trie and an optional "best value to date" coupled with the number
66         of characters that best value is replacing.  done is similar.
67      *)
68      if i >= sz then
69        let
70          fun updcurrent (i, (t, NONE)) = NONE
71            | updcurrent (i, (t, SOME v)) = SOME (i, v)
72        in
73          k (List.revAppend (done, List.mapPartial updcurrent cont))
74        end
75      else
76        let
77          val c = String.sub(s,i)
78          fun newcellf inv old =
79            if inv then old
80            else
81              case Binarymap.peek(dictOf trie0, c) of
82                  NONE => old
83                | SOME t =>
84                    (i, (t, Option.map (fn v => (v,1)) (valueOf t)))::old
85          fun updcells doneA continuingA cells invalidate k =
86            case cells of
87                [] => k doneA (List.rev (newcellf invalidate continuingA))
88              | ((cell as (starti, (t, bestopt)))::rest) =>
89                let
90                in
91                  case Binarymap.peek(dictOf t, c) of
92                      NONE =>
93                        (case bestopt of
94                             NONE => updcells doneA continuingA
95                                              rest invalidate k
96                           | SOME (v,c) =>
97                             updcells ((starti,(v,c)) :: doneA) continuingA
98                                      rest invalidate k)
99                    | SOME t' =>
100                      (case valueOf t' of
101                           NONE => updcells
102                                     doneA
103                                     ((starti,(t',bestopt)) :: continuingA)
104                                     rest
105                                     invalidate k
106                         | SOME v' =>
107                           let
108                             val cnt = i - starti + 1
109                           in
110                             updcells
111                               doneA
112                               ((starti, (t', SOME (v',cnt))) :: continuingA)
113                               (List.filter (fn (j, _) => j > i) rest)
114                               true
115                               k
116                           end)
117                end
118        in
119          updcells done [] cont false
120                   (fn done => fn cont => onestep (i + 1) done cont k)
121        end
122  in
123    onestep 0 [] [] (fn m => final_replacement s m)
124  end
125
126fun subst theta =
127  let
128    fun foldthis ({redex,residue}, t) =
129      if size redex <> 0 then
130        insert(t, redex, residue)
131      else raise Fail "stringfindreplace.subst : redex is empty string"
132    val t = List.foldl foldthis (empty()) theta
133  in
134    foldcheck t
135  end
136
137end
138