(* Title:  Specify/refine.sml

    Author: Walther Neuper 110226

    (c) due to copyright terms

 Operations on models.

 *)

 signature REFINE_PROBLEM =

 sig

   val problem: theory -> Problem.id -> I_Model.T -> (Problem.id * (I_Model.T * Pre_Conds.T)) option

   val refine_ori : O_Model.T -> Problem.id -> Problem.id option

   val refine_ori' : O_Model.T -> Problem.id -> Problem.id

 \<^isac_test>\<open>

   val refine : Formalise.model -> Problem.id -> M_Match.T list

   datatype match_ = Match_ of Problem.id * (( I_Model.T) * (Pre_Conds.T)) | NoMatch_;

   val refined_: match_ list -> match_ option

   val refin'': theory -> Problem.id -> I_Model.T -> match_ list -> Probl_Def.T Store.node -> match_ list

   val refins'': theory -> Problem.id -> I_Model.T -> match_ list -> Probl_Def.T Store.node list -> match_ list

 \<close>

 end

 (**)

 structure Refine(**) : REFINE_PROBLEM(**) =

 struct

 (**)

 datatype match_ = 

   Match_ of Problem.id * (( I_Model.T) * (Pre_Conds.T))

 | NoMatch_;

 fun is_matches_ (Match_ _) = true

   | is_matches_ _ = false;

 fun refined_ ms = ((find_first is_matches_) o rev) ms;

 fun eq1 d (_, (d', _)) = (d = d');

 fun chk_ (_: theory) pbt (i, vats, b, f, I_Model.Cor ((d, vs), _)) =

       (case find_first (eq1 d) pbt of 

         SOME (_, (_, id)) => (i, vats, b, f, I_Model.Cor ((d, vs), (id, I_Model.pbl_ids' d vs)))

       | NONE =>  (i, vats, false, f, I_Model.Sup (d, vs)))

   | chk_ _ pbt (i, vats, b, f, I_Model.Inc ((d, vs), _)) =

       (case find_first (eq1 d) pbt of 

         SOME (_, (_, id)) => (i, vats, b, f, I_Model.Cor ((d, vs), (id, I_Model.pbl_ids' d vs)))

       | NONE => (i, vats, false, f, I_Model.Sup (d, vs)))

   | chk_ _ _ (itm as (_, _, _, _, I_Model.Syn _)) = itm

   | chk_ _ _ (itm as (_, _, _, _, I_Model.Typ _)) = itm

   | chk_ _ pbt (i, vats, b, f, I_Model.Sup (d, vs)) =

       (case find_first (eq1 d) pbt of 

         SOME (_, (_, id)) => (i, vats, b, f, I_Model.Cor ((d,vs), (id, I_Model.pbl_ids' d vs)))

       | NONE => (i, vats, false, f, I_Model.Sup (d, vs)))

   | chk_ _ pbt (i, vats, _, f, I_Model.Mis (d, vs)) =

       (case find_first (eq1 d) pbt of

         SOME (_, _) => raise ERROR "chk_: ((i,vats,b,f,I_Model.Cor ((d,vs),(id, I_Model.pbl_ids' d vs))):itm)"

       | NONE => (i, vats, false, f, I_Model.Sup (d, [vs])))

   | chk_ _ _ _ = raise ERROR "chk_: uncovered fun def.";

 fun eq2 (_, (d, _)) (_, _, _, _, itm_) = d = I_Model.descriptor itm_;

 fun eq0 (0, _, _, _, _) = true

   | eq0 _ = false;

 fun max_i i [] = i

   | max_i i ((id, _, _, _, _) :: is) = if i > id then max_i i is else max_i id is;

 fun max_id [] = 0

   | max_id ((id, _, _, _, _) :: is) = max_i id is;

 fun add_idvat itms _ _ [] = itms

   | add_idvat itms i mvat ((_, _, b, f, itm_) :: its) =

     add_idvat (itms @ [(i, [], b, f, itm_)]) (i + 1) mvat its;

 (* find elements of pbt not contained in itms;

    if such one is untouched, return this one, otherwise create new itm *)

 fun chk_m itms untouched (p as (f, (d, id))) = 

   case find_first (eq2 p) itms of

 	  SOME _ => []

   | NONE =>

       (case find_first (eq2 p) untouched of

         SOME itm => [itm]

       | NONE => [(0, [], false, f, I_Model.Mis (d, id))]);

 fun chk_mis mvat itms untouched pbt = 

     let val mis = (flat o (map (chk_m itms untouched))) pbt; 

         val mid = max_id itms;

     in add_idvat [] (mid + 1) mvat mis end;

 (* check a problem (ie. itm list) for matching a problemtype, 

    takes the I_Model.max_variant for concluding completeness (could be another!) *)

 fun match_itms thy itms (pbt, pre, prls) = 

   let

     fun okv mvat (_, vats, b, _, _) = member op = vats mvat andalso b;

     val itms' = map (chk_ thy pbt) itms; (* all found are #3 true *)

     val mvat = I_Model.max_variant itms';

 	  val itms'' = filter (okv mvat) itms';

 	  val untouched = filter eq0 itms; (* i.e. dsc only (from init)*)

 	  val mis = chk_mis mvat itms'' untouched pbt;

 	  val (pb, pre')  = Pre_Conds.check prls pre itms'' mvat

   in (length mis = 0 andalso pb, (itms'@ mis, pre')) end;

 (* refine a problem; version for tactic Refine_Problem *)

 fun refin'' _ (pblRD: Problem.id) itms pbls (Store.Node (pI, [py], [])) =

     let

 	    val {thy, ppc, where_, prls, ...} = py 

 	    val (b, (itms', pre')) = match_itms thy itms (ppc, where_, prls);

     in

       if b

       then pbls @ [Match_ (rev (pblRD @ [pI]), (itms', pre'))]

       else pbls @ [NoMatch_] 

     end

   | refin'' _ pblRD itms pbls (Store.Node (pI, [py], pys)) =

     let

       val {thy, ppc, where_, prls, ...} = py 

       val (b, (itms', pre')) = match_itms thy itms (ppc, where_, prls);

     in if b 

        then let val pbl = Match_ (rev (pblRD @ [pI]), (itms', pre'))

 	    in refins'' thy (pblRD @ [pI]) itms (pbls @ [pbl]) pys end

        else (pbls @ [NoMatch_])

     end

   | refin'' _ _ _ _ _ = raise ERROR "refin'': uncovered fun def."

 and refins'' _ _ _ pbls [] = pbls

   | refins'' thy pblRD itms pbls ((p as Store.Node _) :: pts) =

     let

       val pbls' = refin'' thy pblRD itms pbls p

     in case last_elem pbls' of

       Match_ _ => pbls'

     | NoMatch_ => refins'' thy pblRD itms pbls' pts

   end;

 fun problem thy pblID itms =

   case refined_ ((Store.apply (get_ptyps ())) (refin'' thy ((rev o tl) pblID) itms [])

       pblID (rev pblID)) of

 	  NONE => NONE

   | SOME (Match_ (rfd as (pI', _))) => if pblID = pI' then NONE else SOME rfd

   | _ => raise ERROR "Refine.problem: uncovered case refined_";

 (* refine a problem; construct pblRD while scanning *)

 fun refin pblRD ori (Store.Node (pI, [py], [])) =

     if M_Match.match_oris (#thy py) (#prls py) ori (#ppc py, #where_ py) 

     then SOME (pblRD @ [pI])

     else NONE

   | refin pblRD ori (Store.Node (pI, [py], pys)) =

     if M_Match.match_oris (#thy py) (#prls py) ori (#ppc py, #where_ py) 

     then (case refins (pblRD @ [pI]) ori pys of

 	      SOME pblRD' => SOME pblRD'

 	    | NONE => SOME (pblRD @ [pI]))

     else NONE

   | refin _ _ _ = raise ERROR "refin: uncovered fun def."

 and refins _ _ [] = NONE

   | refins pblRD ori ((p as Store.Node _) :: pts) =

     (case refin pblRD ori p of

       SOME pblRD' => SOME pblRD'

     | NONE => refins pblRD ori pts);

 (* refine a problem; version providing output for math-experts *)

 \<^isac_test>\<open>

 fun refin' pblRD fmz pbls (Store.Node (pI, [py: Probl_Def.T], [])) =

     let

       val _ = (tracing o (curry op ^ "*** pass ") o strs2str) (pblRD @ [pI])

       val {thy, ppc, where_, prls, ...} = py 

       val oris = O_Model.init thy fmz ppc(* |> #1*);

       (* WN020803: itms!: oris might _not_ be complete here *)

       val (b, (itms, pre')) = M_Match.match_oris' thy oris (ppc, where_, prls)

     in

       if b

       then pbls @ [M_Match.Matches (rev (pblRD @ [pI]), P_Model.from thy itms pre')]

       else pbls @ [M_Match.NoMatch (rev (pblRD @ [pI]), P_Model.from thy itms pre')]

     end

   | refin' pblRD fmz pbls (Store.Node (pI, [py], pys)) =

     let

       val _ = (tracing o ((curry op ^)"*** pass ") o strs2str) (pblRD @ [pI])

       val {thy, ppc, where_, prls, ...} = py 

       val oris = O_Model.init thy fmz ppc(* |> #1*);

       (* WN020803: itms!: oris might _not_ be complete here *)

       val(b, (itms, pre')) = M_Match.match_oris' thy oris (ppc,where_,prls);

     in

       if b 

       then

         let val pbl = M_Match.Matches (rev (pblRD @ [pI]), P_Model.from thy itms pre')

 	      in refins' (pblRD @ [pI]) fmz (pbls @ [pbl]) pys end

       else (pbls @ [M_Match.NoMatch (rev (pblRD @ [pI]), P_Model.from thy itms pre')])

     end

   | refin' _ _ _ _ = raise ERROR "refin': uncovered fun def."

 and refins' _ _ pbls [] = pbls

   | refins' pblRD fmz pbls ((p as Store.Node _) :: pts) =

     let

       val pbls' = refin' pblRD fmz pbls p

     in

       case last_elem pbls' of

         M_Match.Matches _ => pbls'

       | M_Match.NoMatch _ => refins' pblRD fmz pbls' pts

     end;

 \<close>

 (* apply a fun to a ptyps node *)

 fun app_ptyp x = Store.apply (get_ptyps ()) x;

 (* for tactic Refine_Tacitly

    oris are already created wrt. some pbt; pbt contains thy for parsing *)

 fun refine_ori oris pblID =

   let

     val opt = app_ptyp (refin ((rev o tl) pblID) oris) pblID (rev pblID);

     in case opt of 

       SOME pblRD =>

         let val pblID': Problem.id = rev pblRD

 			  in if pblID' = pblID then NONE else SOME pblID' end

 	  | NONE => NONE

 	end;

 fun refine_ori' oris pI = perhaps (refine_ori oris) pI;

 (* for math-authoring and test; TODO: needs thy for parsing fmz *)

 \<^isac_test>\<open>

 fun refine fmz pblID =

   app_ptyp (refin' ((rev o tl) pblID) fmz []) pblID (rev pblID);

 \<close>

 (**)end(**)