(* overlap.sml *)
(* Initially by joev *)

(* This will eventually implement the overlap inversion optimization, or *)
(* something like it.  Right now it's just a mess.  Don't use it.        *)

structure Overlapping =
  struct

    open Lil
    structure T = Token
      
    val debug = 
      Params.flag false
      (SOME("-debug-overlap", "turn on debugging for the overlap inversion pass"))
      "debug-overlap"



    datatype scanresult = 
      END
    | JOINT of (T.token list * T.tag * T.tag list * T.tag * T.tag list * 
		T.token list)


    (* finish_range_[ltr|rtl] tg lev acc toklist              *)
    (* scan through toklist looking for a closing (opening) tag               *)
    (* matching tg, lev levels out; return (stuff before tag,stuff after tag) *)
    (* It is expected that in the ltr case toklist will be in original        *)
    (* document order, but in the rtl case toklist will be in reversed order. *)
    fun finish_range_ltr t lvl past [] = raise Fail "Where's the rest?"
      | finish_range_ltr t 0 past ((T.Closetag t')::future) =
      if t = t' then (rev past,future)
      else raise Fail "Closing tag missing!"
      | finish_range_ltr t s past ((T.Closetag t')::future) =
	finish_range_ltr t (s-1) ((T.Closetag t')::past) future
      | finish_range_ltr t s past ((T.Tag t')::future) =
	finish_range_ltr t (s+1) ((T.Tag t')::past) future
      | finish_range_ltr t s past ((T.Text tx)::future) =
	finish_range_ltr t s ((T.Text tx)::past) future

    fun finish_range_rtl t lvl acc [] = raise Fail "Where's the beginning?"
      | finish_range_rtl t 0   acc ((T.Tag t')::past) =
      if t = t' then (acc,past)
      else 
	let val msg = "Opening <" ^ (T.tts t) ^ "> tag missing!"
	in
	  (if !debug then
	     (print msg;
	      print "\n";
	      Print.linearoutput ((T.Tag t')::acc);
	      print "\n")
	   else ();
	     raise Fail msg)
	end
      | finish_range_rtl t s   acc ((T.Tag t')::past) =
	finish_range_rtl t (s-1) ((T.Tag t')::acc) past
      | finish_range_rtl t s   acc ((T.Closetag t')::past) =
	finish_range_rtl t (s+1) ((T.Closetag t')::acc) past
      | finish_range_rtl t s   acc ((T.Text tx)::past) =
	finish_range_rtl t s ((T.Text tx)::acc) past


    fun findmatch ct seen [] = NONE
      | findmatch ct seen (t::ts) =
      if t = ct then SOME (rev seen,ts)
      else findmatch ct (t::seen) ts
	

    fun commutesall t = List.all (Il.commutes t)

	    
    (* </ >...</ ></ct>< >....< ><ct>e</ct>rest *)
    (*   |-cts--|       |-bfor-|                *)
    (*            becomes                       *)
    (* </cts><bfor>e</bfor></ct><bfor>rest      *)
    (* and try to move in again.                *)
    fun push_left cost ct cts bfor after e2 rest =
      (case cts of
	 [] => (* Have to stop here. *)
	   let
	     val e = (map T.Tag after) @ e2
	     val inside = 
	       (map T.Tag bfor) @ e @ (map T.Closetag (rev bfor))
	     val outside = map T.Tag bfor
	   in 
	     (rev (inside @ (T.Closetag ct)::outside),rest,cost)
	   end
       | (ct'::cts') =>
	   let
	     val openers' = bfor @ after
	     val rest' = 
	       e2 @ (map T.Closetag (rev bfor)) @ (T.Closetag ct) ::
	       (map T.Tag bfor) @ rest
	   in try_left cost ct' cts' openers' rest'
	   end)
		
    (* </ >...</ ></ct>< >......< >rest *)
    (*   |-cts--|       |openers-|      *)
    and try_left cost ct cts openers rest =
      (case findmatch ct [] openers of
	 NONE => ((map T.Tag (rev openers)) @ (map T.Closetag (ct::cts)),
		  rest,cost)
       | SOME (bfor,after) =>
	   if commutesall ct bfor then
	     let
	       val (e2,rest) = finish_range_ltr ct (length after) [] rest
	     in push_left (cost-2) ct cts bfor after e2 rest
	     end
	   else
	     ((map T.Tag (rev openers)) @ (map T.Closetag (ct::cts)),
	      rest,cost))


    fun push_right cost past e1 bfor after ot ots =
      (case ots of
	 [] => (* Have to stop here. *)
	   let
	     val e = e1 @ (map T.Closetag bfor)
	     val inside =
	       (map T.Tag (rev after)) @ e @ (map T.Closetag after)
	     val outside = map T.Closetag after
	   in
	     (cost,past,outside @ (T.Tag ot) :: inside)
	   end
       | (ot'::ots') =>
	   let
	     val closers' = bfor @ after
	     val past' = 
	       (rev e1) @
	       (map T.Tag after) @ (T.Tag ot) ::
	       (rev (map T.Closetag after)) @ past
	   in try_right cost past' closers' ot' ots'
	   end)


    and try_right cost past closers ot ots =
       (case findmatch ot [] closers of
	 NONE => (cost,past,(map T.Closetag closers) @ (map T.Tag (ot::ots)))
       | SOME (bfor,after) =>
	   if commutesall ot after then
	     let
	       val _ = 
		 if !debug then
		   (print "Moving to the right through <";
		    print (T.tts ot);
		    print ">\n";
		    print "Before closer: ";
		    Print.linearoutput (map (T.Closetag) (rev bfor));
		    print "\nAfter closer: ";
		    Print.linearoutput (map (T.Closetag) after);
		    print "\n"
		    )
		 else ()
	       val (e1,past) = finish_range_rtl ot (length bfor) [] past
             in push_right (cost-2) past e1 (bfor) after ot ots
             end
           else
	     (cost,past,(map T.Closetag closers) @ (map T.Tag (ot::ots))))

    
    fun lookat (past,ct,cts,ot,ots,rest) =
      let
	val openers = ot::ots
	val closers = ct::cts
	val (lpast,lfuture,lcost) = 
	  try_left (length openers) ct cts openers rest
	val (rcost,rpast,rfuture) =
	  try_right (length closers) past (rev closers) ot ots
	fun default () =
	  ((map T.Tag (rev openers)) @ (map T.Closetag closers) @ past, 
	   rest)
      in
	if lcost < rcost then
	  if lcost < 0 then
	    (lpast@past,lfuture)
	  else
	    default ()
	else
	  if rcost < 0 then
	    (rpast,rfuture@rest)
	  else
	    default ()
      end

    (* past is the reverse of the token list up to the first recent closer. *)
    fun scan past closers [] = END
      | scan past closers ((T.Closetag t)::rest) = 
        scan past (t::closers) rest
      | scan past closers ((T.Text s)::rest) = 
	scan ((T.Text s)::((map T.Closetag closers) @ past)) [] rest
      | scan past [] ((T.Tag t)::rest) =
	scan ((T.Tag t)::past) [] rest
      | scan past (ct::cts) ((T.Tag ot)::l) =
	let
	  fun collect [] = raise Fail "Where's the rest of the exp?"
	    | collect (l as ((T.Text _)::_)) = ([],l)
	    | collect (l as ((T.Closetag _)::_)) = ([],l)
	    | collect ((T.Tag t)::rest) = 
	    let val (openers,rest) = collect rest
	    in (t::openers,rest)
	    end
	  val (openers,rest) = collect l
	in JOINT (past,ct,cts,ot,openers,rest)
	end


    fun opt_tok_list past future =
      (case scan past [] future of
	 END => (rev past) @ future
       | JOINT stuff =>
	   let val (past,future) = lookat stuff
	   in opt_tok_list past future
	   end)

    val optimize = FuseTagsLinear.fuse o (opt_tok_list [])

  end