1.1 --- a/src/sml/ME/ctreeNEW.sml Thu Feb 24 12:58:42 2005 +0100
1.2 +++ b/src/sml/ME/ctreeNEW.sml Fri Feb 25 09:27:10 2005 +0100
1.3 @@ -3,74 +3,39 @@
1.4 *)
1.5
1.6
1.7 -
1.8 -(*drop first element and make run on []*)
1.9 -fun get_tlpos' p pt =
1.10 - let val ps = get_allpos' p pt
1.11 - in if null ps then ps else tl ps end;
1.12 -fun get_tlpos's p pts =
1.13 - let val ps = get_allpos's p pts
1.14 - in if null ps then ps else tl ps end;
1.15 -
1.16 -(*---OLD---*)
1.17 -fun get_allp (cuts: pos' list) (P:pos) pt ((p, p_): pos') =
1.18 - (let val nxt = move_dn P pt (drop (length P, p), p_)
1.19 - (*exn if Incomplete reached*)
1.20 - in if nxt <> ([],Res)
1.21 - then get_allp (cuts @ [nxt]) P pt nxt
1.22 - else (cuts @ [nxt]): pos' list
1.23 - end) handle PTREE _ => cuts;
1.24 (*.get all positions in a ptree until ([],Res) or ostate=Incomplete
1.25 val get_allp = fn :
1.26 pos' list -> : accumulated, start with []
1.27 pos -> : the offset for subtrees wrt the root
1.28 ptree -> : (sub)tree
1.29 - pos' : before the positions in ...
1.30 + pos' : initialization (the last pos' before ...)
1.31 -> pos' list : of positions in this (sub) tree (relative to the root)
1.32 .*)
1.33 -print_depth 11;
1.34 -(* val (cuts, P, pt, pos) = ([], [3], get_nd pt [3], ([]:int list,Frm));
1.35 - *)
1.36 -(*----OLD-----*)
1.37 -fun get_allp (cuts: pos' list) (P:pos) pt (pos:pos') =
1.38 - (let val nxt = move_dn P pt pos
1.39 - (*exn if Incomplete reached*)
1.40 - in if nxt <> ([],Res)
1.41 - then get_allp (cuts @ [nxt]) P pt nxt
1.42 - else (cuts @ [nxt]): pos' list
1.43 - end) handle PTREE _ => cuts;
1.44 -print_depth 3;
1.45 (*###################################################################*)
1.46 -print_depth 11;
1.47 (* val (cuts, P, pt, pos) = ([], [3], get_nd pt [3], ([], Frm):pos');
1.48 val (cuts, P, pt, pos) = ([], [2], get_nd pt [2], ([], Frm):pos');
1.49 length (children pt);
1.50 *)
1.51 -fun get_allp (cuts:pos' list) (P:pos) pt (pos:pos') =
1.52 +fun get_allp (cuts:pos' list) (P:pos, pos:pos') pt =
1.53 (let val nxt = move_dn [] pt pos (*exn if Incomplete reached*)
1.54 in if nxt <> ([],Res)
1.55 - then get_allp (cuts @ [nxt]) P pt nxt
1.56 + then get_allp (cuts @ [nxt]) (P, nxt) pt
1.57 else (map (apfst (curry op@ P)) (cuts @ [nxt])): pos' list
1.58 end) handle PTREE _ => (map (apfst (curry op@ P)) cuts);
1.59 -print_depth 3;
1.60 (*###################################################################*)
1.61
1.62
1.63
1.64 -(*----OLD-----*)
1.65 -print_depth 11;
1.66 -(*the pts are assumed to be on the same level*)
1.67 -fun get_allps (cuts: pos' list) (P:pos) (pt::pts) =
1.68 - let val cuts' = get_allp [] P pt ([], Frm)
1.69 - val nxt = last_elem cuts'
1.70 - in if nxt <> ([],Res)
1.71 - then get_allps (cuts @ cuts') P pts
1.72 - else cuts @ cuts'
1.73 - end;
1.74 -print_depth 3;
1.75 (* use"ME/ctreeNEW.sml";
1.76 use"ctreeNEW.sml";
1.77 *)
1.78 +(*----OLD-----*)
1.79 +fun get_allps (cuts: pos' list) (P:pos) [] = cuts
1.80 + | get_allps cuts P (pt::pts) =
1.81 + let val cuts' =
1.82 + get_allp [] (P, ([], Frm)) pt
1.83 + in get_allps (cuts @ cuts') (lev_on P) pts end;
1.84 +
1.85 print_depth 11;
1.86 (* val (cuts: pos' list, P, pt::pts) = ([], [1], children pt);
1.87 val cuts' = get_allp [] P pt ([], Frm);
1.88 @@ -79,10 +44,17 @@
1.89 length (children pt);
1.90 *)
1.91 (*the pts are assumed to be on the same level*)
1.92 -fun get_allps (cuts: pos' list) (P:pos) (pt::pts) =
1.93 - let val cuts' = get_allp [] P pt ([], Frm)
1.94 - in get_allps (cuts @ cuts') (lev_on P) pts end;
1.95 -print_depth 3;
1.96 +fun get_allps (cuts: pos' list) (P:pos) [] = cuts
1.97 + | get_allps cuts P (pt::pts) =
1.98 + let val below = get_allp [] (P, ([], Frm)) pt
1.99 + val levfrm =
1.100 + if is_pblnd pt
1.101 + then (P, Pbl)::below
1.102 + else if last_elem P = 1
1.103 + then (P, Frm)::below
1.104 + else (*Trans*) below
1.105 + val levres = levfrm @ (if null below then [(P, Res)] else [])
1.106 + in get_allps (cuts @ levres) (lev_on P) pts end;
1.107
1.108
1.109 fun del_res (PblObj {cell, fmz, origin, spec, probl, meth,
1.110 @@ -108,13 +80,20 @@
1.111 WN050221 for test on worksheet*)
1.112 | test_trans _ = false;
1.113
1.114 -(*WN050220: new design S(603)..(608)
1.115 -p_ is not required !!!*)
1.116 +(*cut_bottom new S(603)..(608)
1.117 +cut the level at the bottom of the pos (used by cappend_...)
1.118 +and handle the parent in order to avoid extra case for root
1.119 +fn: ptree -> : the _whole_ ptree for cut_levup
1.120 + pos * posel -> : the pos after split_last
1.121 + ptree -> : the parent of the Nd to be cut
1.122 + ptree * pos' list: the updated ptree and the pos's cut
1.123 +*)
1.124
1.125 (* val (cuts, P, pt as Nd (b,bs), (p::[])) = ([], [], pt, pos);
1.126 val (cuts, P, pt as Nd (b,bs), (p::[])) = ([], [], pt, [2]);
1.127 *)
1.128 -fun cut_tre cuts P (Nd (b, bs)) (p::[]) =
1.129 +(**#############before bottom..levup ####################################**)
1.130 +fun cut_bottom cuts P (Nd (b, bs)) (p::[]) =
1.131 let (*top down divide each level into 3 parts...*)
1.132 val keep = take (p - 1, bs)
1.133 val Nd (b',bs') = nth p bs(*here* will be 'insert'ed by 'append_..'*)
1.134 @@ -130,12 +109,12 @@
1.135 cuts
1.136 @ (get_allpos's (P @ [p], 1) bs'))
1.137 end
1.138 - | cut_tre cuts P (pt as Nd (b,bs)) (p::ps) = (pt,[])
1.139 + | cut_bottom cuts P (pt as Nd (b,bs)) (p::ps) = (pt,[])
1.140 ;
1.141 (*
1.142 let (*top down divide each level into 3 parts...*)
1.143 val keep = take (p - 1, bs)
1.144 - val (pt' as (Nd (b',_)), cuts') = cut_tre cuts (P@[p]) (nth p bs) ps
1.145 + val (pt' as (Nd (b',_)), cuts') = cut_bottom cuts (P@[p]) (nth p bs) ps
1.146 val tail = takerest (p, bs)
1.147 in if test_trans b'
1.148 then (Nd ((*if P=[]...del_res*)b,
1.149 @@ -145,4 +124,83 @@
1.150 cuts @ cuts' @ ([(*Res pt'*)]))
1.151 end
1.152 *)
1.153 -fun cut_tree pt (pos,_) = cut_tre [] [] pt pos;
1.154 +print_depth 3;
1.155 +(**############# result constructed goOn finished ########################**)
1.156 +print_depth 99;
1.157 +fun cut_bottom (pt:ptree) (P:pos, p:posel) (Nd (b, bs)) =
1.158 + let (*divide level into 3 parts...*)
1.159 + val keep = take (p - 1, bs)
1.160 + val Nd (b',bs') = nth p bs(*here* will be 'insert'ed by 'append_..'*)
1.161 + val tail = takerest (p, bs)
1.162 + val (children, cuts) =
1.163 + if test_trans b'
1.164 + then (keep,
1.165 + (get_allpos's (P @ [p], 1) bs')
1.166 + @ (get_allpos's (P, p + 1) tail))
1.167 + else (keep @ [(*'insert'ed by 'append_..'*)] @ tail,
1.168 + get_allpos's (P @ [p], 1) bs')
1.169 + val (parent, cuts) =
1.170 + if test_trans b
1.171 + then (Nd (del_res b, children),
1.172 + cuts @ (if g_ostate b = Incomplete then [(P,Res)] else []))
1.173 + else (Nd (b, children), cuts)
1.174 + val cutlevup = test_trans b
1.175 + in (parent, cuts:pos' list) end;
1.176 +print_depth 3;
1.177 +(**############# new get_allpos ########################################**)
1.178 +print_depth 99;
1.179 +fun cut_bottom (pt:ptree) (P:pos, p:posel) (Nd (b, bs)) =
1.180 + let (*divide level into 3 parts...*)
1.181 + val keep = take (p - 1, bs)
1.182 + val Nd (b',bs') = nth p bs(*here* will be 'insert'ed by 'append_..'*)
1.183 + val tail = takerest (p, bs)
1.184 + val (children, cuts) =
1.185 + if test_trans b'
1.186 + then (keep,
1.187 + (get_allps [] (P @ [1]) bs')
1.188 + @ (get_allps [] (P @ [1]) tail))
1.189 + else (keep @ [(*'insert'ed by 'append_..'*)] @ tail,
1.190 + get_allps [] (P @ [1]) bs')
1.191 + val (parent, cuts) =
1.192 + if test_trans b
1.193 + then (Nd (del_res b, children),
1.194 + cuts @ (if g_ostate b = Incomplete then [(P,Res)] else []))
1.195 + else (Nd (b, children), cuts)
1.196 + val cutlevup = test_trans b
1.197 + in (parent, cuts:pos' list) end;
1.198 +print_depth 3;
1.199 +(**############# correct call of get_allps##############################**)
1.200 +print_depth 99;
1.201 +fun cut_bottom (pt:ptree) (P, p) (Nd (b, bs)) =
1.202 + let (*divide level into 3 parts...*)
1.203 + val keep = take (p - 1, bs)
1.204 + val Nd (b',bs') = nth p bs(*here* will be 'insert'ed by 'append_..'*)
1.205 + val (tail, tp) = (takerest (p, bs),
1.206 + if null (takerest (p, bs)) then 0 else p + 1)
1.207 + val _= writeln("###cut_bottom: call get_allps with"^pos2str (P @ [1]));
1.208 + val (children, cuts) =
1.209 + if test_trans b'
1.210 + then (keep,
1.211 + ( get_allps [] (P @ [p] @ [1]) bs') (*1 lev_dn*)
1.212 + @ (get_allps [] (P @ [p+1]) tail)) (*on level*)
1.213 + else (keep @ [(*'insert'ed by 'append_..'*)] @ tail,
1.214 + get_allps [] (P @ [p] @ [1]) bs')
1.215 + val (parent, cuts) =
1.216 + if test_trans b
1.217 + then (Nd (del_res b, children),
1.218 + cuts @ (if g_ostate b = Incomplete then [(P,Res)] else []))
1.219 + else (Nd (b, children), cuts)
1.220 + val cutlevup = test_trans b
1.221 + in (parent, cuts:pos' list) end;
1.222 +print_depth 3;
1.223 +(**######################################################################**);
1.224 +
1.225 +
1.226 +fun cut_tree pt (pos,_) =
1.227 + let val (P, p) = split_last pos;
1.228 + val (pt, cuts) = cut_bottom pt (P, p) (get_nd pt P)
1.229 + in (pt, cuts) end;
1.230 +
1.231 +print_depth 99;
1.232 +cut_tree;
1.233 +print_depth 3;
2.1 --- a/src/sml/systest/ctree.sml Thu Feb 24 12:58:42 2005 +0100
2.2 +++ b/src/sml/systest/ctree.sml Fri Feb 25 09:27:10 2005 +0100
2.3 @@ -949,12 +949,13 @@
2.4 val ((pt,_),_) = get_calc 1;
2.5 show_pt pt;
2.6
2.7 -(**##############################################################(**)
2.8 +(**##############################################################**)
2.9 "-------------- get_allpos' new ----------------------------------";
2.10 "-------------- get_allpos' new ----------------------------------";
2.11 "-------------- get_allpos' new ----------------------------------";
2.12 +"--- whole ctree";
2.13 print_depth 99;
2.14 -val cuts = get_allp [] [] pt ([],Frm);
2.15 +val cuts = get_allp [] ([], ([],Frm)) pt;
2.16 print_depth 3;
2.17 if cuts =
2.18 [([1], Frm),
2.19 @@ -969,62 +970,66 @@
2.20 ([3], Res),
2.21 ([4], Res),
2.22 ([], Res)] then () else
2.23 -raise error "ctree.sml diff.behav. get_allpos' new ([],Frm)";
2.24 -
2.25 +raise error "ctree.sml diff.behav. get_allp new []";
2.26
2.27 print_depth 99;
2.28 -val cuts = get_allp [] [2] (get_nd pt [2]) ([],Frm);
2.29 +val cuts2 = get_allps [] [1] (children pt);
2.30 print_depth 3;
2.31 +if cuts = cuts2 @ [([], Res)] then () else
2.32 +raise error "ctree.sml diff.behav. get_allps new []";
2.33 +
2.34 +"--- nd [2] with 6 children---------------------------------";
2.35 +val cuts = get_allp [] ([2], ([],Frm)) (get_nd pt [2]);
2.36 if cuts =
2.37 - [...........] then () else
2.38 -raise error "ctree.sml diff.behav. get_allpos' new ([2],Frm)";
2.39 + [([2, 1], Frm), ([2, 1], Res), ([2, 2], Res), ([2, 3], Res),
2.40 + ([2, 4], Res), ([2, 5], Res), ([2, 6], Res),
2.41 + ([2], Res)] then () else
2.42 +raise error "ctree.sml diff.behav. get_allp new [2]";
2.43
2.44 -print_depth 99;
2.45 -val cuts = get_allp [] [3] (get_nd pt [3]) ([],Frm);
2.46 -print_depth 3;
2.47 +val cuts2 = get_allps [] [2,1] (children (get_nd pt [2]));
2.48 +if cuts = cuts2 @ [([2], Res)] then () else
2.49 +raise error "ctree.sml diff.behav. get_allps new [2]";
2.50 +
2.51 +
2.52 +"--- nd [3] subproblem--------------------------------------";
2.53 +val cuts = get_allp [] ([3], ([],Frm)) (get_nd pt [3]);
2.54 if cuts =
2.55 [([3, 1], Frm),
2.56 ([3, 1], Res),
2.57 ([3, 2, 1], Frm), ([3, 2, 1], Res), ([3, 2, 2], Res),
2.58 ([3, 2], Res),
2.59 ([3], Res)] then () else
2.60 -raise error "ctree.sml diff.behav. get_allpos' new ([3],Frm)";
2.61 +raise error "ctree.sml diff.behav. get_allp new [3]";
2.62
2.63 -print_depth 99;
2.64 -val cuts = get_allps [] [1] (children pt);
2.65 -print_depth 3;
2.66 +val cuts2 = get_allps [] [3,1] (children (get_nd pt [3]));
2.67 +if cuts = cuts2 @ [([3], Res)] then () else
2.68 +raise error "ctree.sml diff.behav. get_allps new [3]";
2.69 +
2.70 +"--- nd [3,2] with 2 children--------------------------------";
2.71 +val cuts = get_allp [] ([3,2], ([],Frm)) (get_nd pt [3,2]);
2.72 if cuts =
2.73 - [] then () else
2.74 -raise error "ctree.sml diff.behav. get_allpos' new ([3],Frm)";
2.75 + [([3, 2, 1], Frm), ([3, 2, 1], Res), ([3, 2, 2], Res),
2.76 + ([3, 2], Res)] then () else
2.77 +raise error "ctree.sml diff.behav. get_allp new [3,2]";
2.78
2.79 +val cuts2 = get_allps [] [3,2,1] (children (get_nd pt [3,2]));
2.80 +if cuts = cuts2 @ [([3, 2], Res)] then () else
2.81 +raise error "ctree.sml diff.behav. get_allps new [3,2]";
2.82
2.83
2.84 -length (children pt);
2.85 -length (children (get_nd pt [2]));
2.86 -val nxt = move_dn [] pt pos;
2.87 -val nxt = move_dn [] pt nxt;
2.88 -print_depth 3;
2.89 -
2.90 +(**#################################################################**)
2.91 +"-------------- cut_tree new (from ptree above)-------------------";
2.92 +"-------------- cut_tree new (from ptree above)-------------------";
2.93 +"-------------- cut_tree new (from ptree above)-------------------";
2.94 show_pt pt;
2.95 -
2.96 -
2.97 -
2.98 -
2.99 -print_depth 99;
2.100 -val cuts = get_allp [] [3,2] (get_nd pt [3,2]) ([],Frm);
2.101 -length (children (get_nd pt [3,2]));
2.102 -show_pt pt;
2.103 -
2.104 -
2.105 -
2.106 -"-------------- cut_tree new (from ptree above)-------------------";
2.107 -"-------------- cut_tree new (from ptree above)-------------------";
2.108 -"-------------- cut_tree new (from ptree above)-------------------";
2.109 (* print_depth 99; cuts; print_depth 3;
2.110 print_depth 99; get_allpos's (P@[p], 0) bs'; print_depth 3;
2.111 print_depth 99; get_allpos's (P,p+1) tail; print_depth 3;
2.112 *)
2.113 val (pt', cuts) = cut_tree pt ([2],Res);
2.114 +print_depth 99;
2.115 +cuts;
2.116 +print_depth 3;
2.117 if cuts = []
2.118 then () else raise error "ctree.sml: diff.behav. cut_tree ([2],Res)";
2.119
2.120 @@ -1045,5 +1050,5 @@
2.121 ([1], Frm),
2.122 ([1], Res)] then () else
2.123 raise error "ctree.sml: diff:behav. in cut_tree 1ad";
2.124 -(**)#################################################################**)
2.125 +(**#################################################################**)
2.126