(* 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

(* ---- for tests only: shifted from below to remove the Warning "unused" at fun.def. --------- *)

  val refine : Formalise.model -> Problem.id -> Model.match list

(*/-------------------------------------------------------- ! aktivate for Test_Isac BEGIN ---\* )

  (*NONE*)

( *\--- ! aktivate for Test_Isac END ----------------------------------------------------------/*)

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.d_in 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_vt 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_vt 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 pre' = Pre_Conds.check prls pre itms'' mvat

	  val pb = foldl and_ (true, map fst pre')

  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 Model.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 Model.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 *)

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

    let

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

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

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

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

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

    in

      if b

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

      else pbls @ [Model.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 fmz thy ppc(* |> #1*);

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

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

    in

      if b 

      then

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

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

      else (pbls @ [Model.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

        Model.Matches _ => pbls'

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

    end;

(* 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 *)

fun refine fmz pblID =

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

(**)end(**)