(* PLShortcut *)
(* Initially by joev *)


(* We try to find Seq's, or parts of Seq's, that look like
        Tag(tgs1,e1) , Text, Tag(tgs2,e2)
where the surrounding context is "plain" and the tag lists tgs1 and tgs2
have something in common.  We factor out the common thing and effectively
turn the whole Seq into
        Tag(common part, Seq[Tag(rest of tgs1,e1),Tag(<PL>,Text),
			     Tag(rest of tgs2,e2)])
When we've contracted part of a Seq in this way, we continue to try to merge
it with stuff on its right.  If we can't, we slide down to the next Tag.  When
we run out, we stop.
*)


structure PLShortcut :> PLSHORTCUT =
  struct

    open Il
    structure M = Meaning


    val debug = 
	Params.flag false
		    (SOME("-debug-plshortcut", "turn on debugging for the <PL> optimizer"))
		    "debug-plshortcut"

    val maxproperty =
      let
	fun folder (a,p) = M.setAttribute (p,a)
      in foldl folder M.null [M.B,M.I,M.S,M.Tt]
      end

    fun isPlain p =
      (not (M.isSetAttribute (p,M.I))) andalso
      (not (M.isSetAttribute (p,M.B))) andalso
      (not (M.isSetAttribute (p,M.Tt))) andalso
      (not (M.isSetAttribute (p,M.Em))) andalso
      (not (M.isSetAttribute (p,M.S))) andalso
      (M.getUnderline p = 0)

    fun transferSize (from,to) =
	let val s = M.getSize from
	in
	    if s < 10 then M.setSize (to,s)
	    else to
	end
    fun transferColor (from,to) =
	let val c = M.getColor from
	in
	    if c < 8 then M.setColor (to,c)
	    else to
	end


    fun desiredOuterContext outer_ctx inner_ctxts =
	if (length inner_ctxts) < 1 then
	    outer_ctx
	else
	    (let
		
		fun examineOneInner (innerctx,(p,emct,minu)) =
		    let
			fun oneAttr (att,p) =
			    if (M.isSetAttribute (innerctx,att)) then
				p
			    else
				M.clearAttribute (p,att)
			val p = foldl oneAttr p [M.B,M.I,M.S,M.Tt]
			val emct = if M.isSetAttribute (innerctx,M.Em) then
				       emct+1
				   else emct-1
			val _ = if !debug then
				    (print "This inner underline level: ";
				     print (Int.toString (M.getUnderline innerctx));
				     print "\n")
				else ()
			val minu = Int.min (minu,M.getUnderline innerctx)
		    in (p,emct,minu)
		    end 
			
		val p = maxproperty
		val p = transferSize (outer_ctx,p)
		val p = transferColor (outer_ctx,p)
			
		val (p,emct,minu) = 
		    foldl examineOneInner (p,0,3) inner_ctxts
		    
		val p = if emct > 0 then (M.setAttribute (p,M.Em))
			else p
		val p = M.setUnderline (p,minu)
	    in p
	    end
		 handle e =>  
			(if !debug then 
			     (print "Exception in PLShortcut.desiredOuterContext!\n";
			      raise e)
			 else
			     raise e))

    (* delta : property * property -> tag list *)
    (* How to get from p1 to p2 *)
    (* PRE: This is possible without any PL tags. *)
    fun delta (p1,p2) =
      (let
	fun addIfNeeded (a,t) res =
	  if M.isSetAttribute (p2,a) andalso not (M.isSetAttribute (p1,a)) then
	    (t::res)
	  else res
	fun fixUnderline res =
	  (case (M.getUnderline p2) - (M.getUnderline p1) of
	     0 => res
	   | 1 => (Token.U::res)
	   | 2 => (Token.U::Token.U::res)
	   | _ => (Token.U::Token.U::Token.U::res))
	fun fixColor res =
	  let val color = M.getColor p2
	  in
	    if color <> M.getColor p1 then
	      (Token.Clr color)::res
	    else res
	  end
	fun fixSize res =
	  let val size = M.getSize p2
	  in
	    if size <> M.getSize p1 then
	      (Token.Num size)::res
	    else res
	  end
	fun fixEmph res =
	    if (M.isSetAttribute (p1,M.Em)) <> (M.isSetAttribute (p2,M.Em)) then
		(Token.EM)::res
	    else res
	val res = []
	val res = addIfNeeded (M.B,Token.Att Token.B) res
	val res = addIfNeeded (M.I,Token.Att Token.I) res
	val res = addIfNeeded (M.S,Token.S) res
	val res = addIfNeeded (M.Tt,Token.TT) res
	val res = fixUnderline res
	val res = fixColor res
	val res = fixSize res
	val res = fixEmph res
      in res
      end
	   handle e => (if !debug then 
			    (print "Exception in PLShortcut.delta!\n";
			     raise e)
			else
			    raise e))

    
    fun flatten_tgs (tgs,body) =
	(case body of
	     Text _ => (tgs,body)
	   | Seq [e] => flatten_tgs (tgs,e)
	   | Seq _ => (tgs,body)
	   | Tag (tgs',body') =>
	     flatten_tgs (tgs @ tgs',body'))
	
    fun opt_exp ctx e =
      let

	(* PRE: ctx is plain. *)
	fun fix_plain_seq es =
	  let

	      fun attempt_merge (tgs1,body1) texts (tgs2,body2) =
		  let
		      val (tgs1,body1) = flatten_tgs (tgs1,body1)
		      val (tgs2,body2) = flatten_tgs (tgs2,body2)
		      val inctx1 = M.addTags(ctx,tgs1)
		      val inctx2 = M.addTags(ctx,tgs2)

		      val infctx = desiredOuterContext ctx [inctx1,inctx2]
		      val outerdelta = delta (ctx,infctx)
		      val pldelta = 
			  (Token.PL)::(delta (M.addTags (infctx,[Token.PL]),ctx))


		      val outerdeltasize =
			  foldl (op +) 0 (map Token.tagsize outerdelta)
		      val pldeltasize =
			  foldl (op +) 0 (map Token.tagsize pldelta)
			
		      fun fixtagelt (tgs,body) =
			  let
			      val innerctx = M.addTags (ctx,tgs)
			      val tgs' = delta (infctx,innerctx)
			  in
			      Tag (tgs',body)
			  end
		      fun fixtextelt s = Tag (pldelta,Text s)

		  in
		      (* Check to see if we're saving any space. *)
		      if pldeltasize > outerdeltasize then
			  NONE
		      else
			  SOME (Tag (outerdelta,Seq ((fixtagelt (tgs1,body1))::
						     (map fixtextelt texts) @
						     [fixtagelt (tgs2,body2)])))
		  end

	      fun scan [] = []
		| scan ((Text s)::es) = (Text s)::(scan es)
		| scan ((Seq es)::es') = scan (es @ es')
		| scan ((Tag (tgs1,body1))::es) =
		  let
		      fun collect [] = ([],[])
			| collect ((Text s)::es) = 
			  let val (others,es') = collect es
			  in (s::others,es')
			  end
			| collect ((Seq es1)::es) =
			  collect (es1 @ es)
			| collect es =
			  ([],es)
		      val (texts,es) = collect es
		  in
		      case es of
			  [] => (Tag (tgs1,body1))::(map Text texts)
			| (Tag (tgs2,body2))::es => 
			  (case attempt_merge (tgs1,body1) texts (tgs2,body2) of
			       NONE => 
			       (Tag (tgs1,body1))::(map Text texts)@
			       scan ((Tag (tgs2,body2))::es)
			     | (SOME e) => scan (e::es))
			| _ => raise Fail "Bug in PLShortcut.scan"
		  end
	      val es = scan es

	  in mkseq es
	  end

	fun self e =
	  (case e of
	     Text s => e
	   | Tag (tgs,e') =>
	       let val ctx' = M.addTags (ctx,tgs)
	       in Tag (tgs,opt_exp ctx' e')
	       end
	   | Seq es =>
	       let
		 val es = map self es
	       in
		 if isPlain ctx then
		   fix_plain_seq es
		 else
		   Il.mkseq es
	       end)
      in self e
      end


    val optimize = opt_exp Meaning.null
      
  end