1#include "share/atspre_staload.hats"
  2#define ATS_DYNLOADFLAG 0
  3
  4staload "graph.sats"
  5staload "types.sats"
  6staload "parse.sats"
  7staload "libats/SATS/dynarray.sats"
  8staload _  = "libats/DATS/dynarray.dats"
  9staload "libats/SATS/hashtbl_linprb.sats"
 10staload _ = "libats/DATS/hashtbl_linprb.dats"
 11staload _ = "libats/DATS/hashfun.dats"
 12staload UN = "prelude/SATS/unsafe.sats"
 13
 14exception GraphErr of ()
 15
 16assume node_id   = usize
 17assume action_id = usize
 18
 19vtypedef thegraph = @{
 20    nodes = dynarray(node),
 21    actions = dynarray(action),
 22    paths = hashtbl(string, node_id)
 23}
 24
 25assume graph = thegraph
 26
 27implement mkgraph() =
 28    let 
 29        val n = dynarray_make_nil<node>           (i2sz (64))
 30        val a = dynarray_make_nil<action>         (i2sz (64))
 31        val p = hashtbl_make_nil<string, node_id> (i2sz(128))
 32    in
 33        @{nodes = n, actions = a, paths = p} 
 34    end
 35
 36fun node_free(n: node): void = 
 37    let 
 38        val @{path = p, producer = pr, consumers = c} = n
 39    in
 40        strptr_free(p);
 41        list_vt_free(c)
 42    end
 43
 44fun action_free(a: action): void = 
 45    let 
 46        val @{inp = i, out = o, rule = r, bindings = b } = a
 47    in
 48        list_vt_free(o);
 49        list_vt_free(i);
 50        strptr_free(r);
 51        bindings_free(b)
 52    end
 53
 54(* define how to destroy one element for array node *)
 55implement array_uninitize$clear<node>(i, node) =
 56   let 
 57       val () = node_free(node)
 58       (* mark as no longer containing anything*)
 59       prval () = topize(node)
 60   in () 
 61   end
 62 
 63(* for array action *)
 64implement array_uninitize$clear<action>(i, action) =
 65    let 
 66        val ()   = action_free(action)
 67        prval () = topize(action)
 68    in ()
 69    end
 70
 71implement graph_free(g) =
 72    let
 73        val @{nodes = n, actions = a, paths = p} = g
 74        var ncount: usize
 75        var acount: usize
 76        (* consume a dynarray and transfer into an arrayptr *)
 77        val nstorage = dynarray_getfree_arrayptr(n, ncount)
 78        val astorage = dynarray_getfree_arrayptr(a, acount)
 79    in 
 80        (* this calls array_uninitize$clear *)
 81        arrayptr_freelin<node>(nstorage, ncount);
 82        arrayptr_freelin<action>(astorage, acount); 
 83        hashtbl_free(p)
 84    end
 85
 86(* ideally we dont search + insert if absent (seeing as hashtbl_insert_opt returns the presence 
 87 * of the id again) it would be better to have 
 88 *
 89 * exists -> return id
 90 * doesent exist -> insert *)
 91(*if a node exists: return it, if it doesnet ,create it and return it*)
 92fun mknode(g: &graph, path: Strptr1): node_id = 
 93    let 
 94        (*XXX unsafe*)
 95        val found = hashtbl_search_opt<string, node_id>(g.paths, $UN.strptr2string(path)) 
 96    in
 97        case+ found of 
 98        | ~Some_vt(id) => ( (*the node exists*)
 99            strptr_free(path); (*free the path we're searching for *)
100            id (*return the node id*) )
101        | ~None_vt()   => ( (* the node doesnt exist *)
102            let val newid = dynarray_get_size(g.nodes) (*the id will be the size of the node array *)
103                val key   = $UN.strptr2string(path) (*borrow key before putting path in the new node*)
104                val newnode : node = @{path = path, producer = None(), consumers = nil_vt()} 
105                val ()    = dynarray_insert_atend_exn<node>(g.nodes, newnode) 
106                val prev  = hashtbl_insert_opt<string, node_id>(g.paths, key, newid) 
107            in  
108                case+ prev of
109                | ~None_vt(  ) => newid 
110                | ~Some_vt(id) => $raise GraphErr
111            end )
112    end
113
114(* call mknode on a list of paths *)
115fun intern_paths {n:nat} (g: &graph, paths: list_vt(Strptr1, n)): list_vt(node_id, n) =
116    case+ paths of
117    | ~nil_vt() => nil_vt() 
118    | ~cons_vt(path, rest) => 
119        let
120            val id  = mknode(g, path)
121            val ids = intern_paths(g, rest)
122            val all = cons_vt(id, ids)
123        in
124            all
125        end
126
127fun setprod(g: &graph, nid: node_id, aid: action_id): void = 
128    let 
129        var n: node = dynarray_takeout_at_exn<node>(g.nodes, nid) (*probably slow to takeout and reinsert*)
130        val hasprod = 
131            case+ n.producer of 
132            | None( ) => false
133            | Some(_) => true
134        val () = 
135            if hasprod then () else n.producer := Some(aid)
136        val () = dynarray_insert_at_exn<node>(g.nodes, nid, n)
137    in
138        if hasprod then $raise GraphErr else ()
139    end
140
141fun setcons(g: &graph, nid: node_id, aid: action_id): void = 
142    let 
143        var n: node = dynarray_takeout_at_exn<node>(g.nodes, nid) (*probably slow to takeout and reinsert*)
144        val ncs     = cons_vt(aid, n.consumers)
145        val ()      = n.consumers := ncs
146        val ()      = dynarray_insert_at_exn<node>(g.nodes, nid, n)
147    in
148        ()
149    end
150
151fun producers(g: &graph, ids: !List0_vt(node_id), aid: action_id): void = 
152    case+ ids of
153    | nil_vt() => ()
154    | @cons_vt(entry, rest) => (
155        setprod(g, entry, aid);
156        producers(g, rest, aid);
157        fold@(ids) )
158
159fun consumers(g: &graph, ids: !List0_vt(node_id), aid: action_id): void = 
160    case+ ids of
161    | nil_vt() => ()
162    | @cons_vt(entry, rest) => (
163        setcons(g, entry, aid);
164        consumers(g, rest, aid);
165        fold@(ids) )
166
167
168fun mkedge(g: &graph, e: edge): void = 
169    let
170        val @{output = o, rule = r, input = i, bindings = b} = e
171        val no        = intern_paths(g, o)
172        val ni        = intern_paths(g, i)
173        val nextid    = dynarray_get_size(g.actions)
174        val ()        = producers(g, no, nextid)
175        val ()        = consumers(g, ni, nextid)
176        val newaction : action = @{inp = ni, out = no, rule = r, bindings = b}
177        val ()        = dynarray_insert_atend_exn<action>(g.actions, newaction)
178    in
179        ()
180    end
181
182(* fun mkedges(g: &graph, edges: List0_vt(edge)): void = *)
183implement mkedges(g, edges) = 
184    case+ edges of 
185    | ~nil_vt() => () 
186    | ~cons_vt(edge, rest) => (
187        mkedge (g, edge);
188        mkedges(g, rest) )
189
190fun dotnodes(g: &graph, i: usize): void = 
191    if i < dynarray_get_size(g.nodes) then
192        let
193            val n  = dynarray_takeout_at_exn<node>(g.nodes, i)
194            val () = println!("  n", i, " [shape=box, label=\"", n.path, "\"];")
195            val () = dynarray_insert_at_exn<node>(g.nodes, i, n)
196        in
197            dotnodes(g, i + i2sz(1))
198        end
199    else ()
200
201fun inputarrows(nodes: !List0_vt(node_id), aid: action_id): void = 
202    case+ nodes of 
203    | nil_vt() => ()
204    | @cons_vt(nid, rest) => (
205        println!("  n", nid, " -> a", aid, ";");
206        inputarrows(rest, aid);
207        fold@(nodes) )
208
209fun outputarrows(nodes: !List0_vt(node_id), aid: action_id): void =
210    case+ nodes of
211    | nil_vt() => ()
212    | @cons_vt(nid, rest) => (
213        println!("  a", aid, " -> n", nid, ";");
214        outputarrows(rest, aid);
215        fold@(nodes) )
216
217fun dotactions(g: &graph, i: usize): void = 
218    if i < dynarray_get_size(g.actions) then
219        let 
220            val a  = dynarray_takeout_at_exn<action>(g.actions, i)
221            val () = println!("  a", i, "[shape=ellipse, label=\"", a.rule, "\"];");
222            val () = inputarrows (a.inp, i)
223            val () = outputarrows(a.out, i)
224            val () = dynarray_insert_at_exn<action>(g.actions, i, a)
225        in
226            dotactions(g, i + i2sz(1))
227        end
228     else()
229
230implement dot(g) = (
231    println!("digraph build {");
232    println!("  rankdir=LR;");
233    dotnodes(g, i2sz(0));
234    dotactions(g, i2sz(0));
235    println!("}") )
236