(* text-renderer.sml *) (* Copyright (C) 2004 Dominic Gelinas improvements Copyright (C) 2006 Cole Hoosier This file is part of crypto, a cryptogram encoder/decoder. See the file COPYING.txt for copying and usage restrictions *) structure TextRenderer : TEXT_RENDERER = struct structure EXB = EXeneBase structure W = Widget structure A = Attrs structure Q = Quark open CML Geometry Interact SyncVar val tm = TraceCML.traceModule(XDebug.eXeneTM, "textrenderer") fun trace f = TraceCML.trace(tm, f) fun debug str = trace(fn () => [str]) val attr_text = Q.quark "text" val attr_font = A.attr_font val attr_rows = Q.quark "rows" val attr_columns = Q.quark "columns" val attr_linewrap = Q.quark "linewrap" val defaultText = "" val defaultFont = "9x15" val defaultRows = 1 val defaultColumns = 80 val defaultLineWrap = false val attrs = [(attr_text, A.AT_Str, A.AV_Str defaultText), (attr_font, A.AT_Font, A.AV_Str defaultFont), (attr_rows, A.AT_Int, A.AV_Int defaultRows), (attr_columns, A.AT_Int, A.AV_Int defaultColumns), (attr_linewrap, A.AT_Bool, A.AV_Bool defaultLineWrap)] datatype font_info = FI of {font : W.EXB.font, fonta : int, fontd : int, maxc : int} (* val fontInfo : Font.font -> font_info *) fun fontInfo font = let val {ascent,descent} = Font.fontHt font val {max_bounds,...} = Font.fontInfoOf font val Font.CharInfo {char_wid,...} = max_bounds in FI{font=font,fonta=ascent,fontd=descent,maxc=char_wid} end type rt = (point * string) list datatype rqst = GetText of string ivar | SetText of string | GetFont of W.EXB.font ivar | SetFont of W.EXB.font | GetRows of int ivar | SetRows of int | GetCols of int ivar | SetCols of int | GetWrap of bool ivar | SetWrap of bool | PtToPos of (point * int ivar) | PosToPt of (int * point ivar) | GetDim of {x_dim : W.dim, y_dim : W.dim} ivar | GetRt of rt ivar | GetRtInRange of ((int * int) * rt ivar) | GetRtToEndOfLine of (int * rt ivar) | GetRtToEndOfText of (int * rt ivar) datatype textrenderer = TR of {rqst : rqst chan, chng : unit chan} datatype txt = TXT of {str : string, fi : font_info, rows : int, cols : int, wrap : bool, text : rt, chng : unit chan} (* val findPos : int * int list * int -> int given that ps is a list of ascending integers, findPos (goal, ps, n) returns a value n' such that n' = n + i, where the i'th value in ps is less-than-or-equal-to goal, and the i+1'th value in ps is greater-than goal. *) fun findPos (goal, nil, n) = n | findPos (goal, p :: ps, n) = if (p > goal) then n else findPos (goal, ps, n + 1) (* val strSplit : string * int -> string * string *) fun strSplit (str, i) = let val s1 = String.extract (str, 0, SOME i) val s2 = String.extract (str, i, NONE) in (s1, s2) end (* val isNewline char -> bool *) fun isNewline c = c = #"\n" (* val fieldsNewline : string -> string list *) val fieldsNewline = String.fields isNewline (* val strToLines : string -> string list splits the string at every occurence of the newline character, and returns the resulting list of strings *) fun strToLines str = let fun insertNewlines ([x], ys) = rev (x :: ys) | insertNewlines (x :: xs, ys) = insertNewlines (xs, (x ^ "\n") :: ys) | insertNewlines (_, _) = raise Fail "cannot happen" in insertNewlines (fieldsNewline str, nil) end (* val pntToPos : G.point * txt -> int *) fun pntToPos (PT{x,y}, txt as TXT{text,fi,...}) = let val goalx = x val goaly = y val FI{font,fonta,fontd,...} = fi val charPositions = Font.charPositions font fun fndPos (nil, n) = n | fndPos ((PT{x,y}, str) :: ts, n) = if y - fonta <= goaly andalso goaly <= y + fontd then findPos (goalx - x, tl (charPositions str), n) else fndPos (ts, n + String.size str) in fndPos (text, 0) end (* val posToPnt : int * txt -> G.point *) fun posToPnt (pos, txt as TXT{text,fi,...}) = let val (firstpt, _) = hd text handle _ => (PT{x=0,y=0}, "") val FI{font,fonta,...} = fi val textWidth = Font.textWidth font fun fndPt (nil, n, pt) = pt | fndPt ((PT{x,y}, str) :: ts, n, pt) = let val len = String.size str in if len < n then fndPt (ts, n - len, PT{x=x + textWidth str,y=y}) (* following three lines added by Alley - probably a hack *) else if len = n andalso not(null ts) then let val (PT{y,...}, _) = hd ts in PT{x=0, y=y} end else let val (s1, s2) = strSplit (str, n) in PT{x=x + textWidth s1,y=y} end end in fndPt (text, pos, firstpt) end (* val gtDim : txt -> {x_dim : W.dim, y_dim : W.dim} *) fun gtDim (TXT{text,fi,rows,cols,wrap,...}) = let val FI{font,fonta,fontd,maxc} = fi val h = W.DIM{base = 0, incr = (fonta + fontd), min = Int.max(length text, rows), nat = Int.max(length text, rows), max = NONE} val w = if wrap then W.DIM{base = maxc * cols, incr = 1, min = 0, nat = 0, max = SOME 0} else let val textWidth = Font.textWidth font fun longest (nil, len) = len | longest ((PT{x,y}, str) :: ls, len) = let val len' = x + textWidth str in if len' > len then longest (ls, len') else longest (ls, len) end val wid = longest (text, cols * maxc) in W.DIM{base = 0, incr = 1, min = wid, nat = wid, max = NONE} end in {x_dim=w,y_dim=h} end (* val gtRt : txt -> rt *) fun gtRt (TXT{text,...}) = text (* val gtRtInRange : (int * int) * txt -> rt *) fun gtRtInRange ((p1, p2), TXT{text,fi,...}) = let val FI{font,...} = fi val textWidth = Font.textWidth font (* getRange : int * int * rt list * rt list -> rt list*) fun getRange (p1, p2, nil, ls) = rev ls | getRange (p1, p2, (PT{x,y}, str) :: ts, ls) = let val len = String.size str in if p1 >= len then getRange (p1 - len, p2 - len, ts, ls) else if p2 > len then let val (s1, s2) = strSplit (str, p1) val len' = String.size str in getRange (0, p2 - len', ts, (PT{x=x + textWidth s1,y=y}, s2) :: ls) end else let val (s1, s2) = strSplit (str, p2) val (s3, s4) = strSplit (s1, p1) in rev ((PT{x=x + textWidth s3,y=y}, s4) :: ls) end end in getRange (p1, p2, text, nil) end (* val gtRtToEndOfLine : int * txt -> rt *) fun gtRtToEndOfLine (pos, TXT{text,fi,...}) = let val FI{font,...} = fi val textWidth = Font.textWidth font (* getRange : int * rt list -> rt list*) fun getRange (pos, nil) = nil | getRange (pos, (PT{x,y}, str) :: ts) = let val len = String.size str in if pos >= len then getRange (pos-len, ts) else let val (s1, s2) = strSplit (str, pos) val len' = String.size str in [(PT{x=x + textWidth s1,y=y}, s2)] end end in getRange (pos, text) end (* val gtRtToEndOfText : int * txt -> rt *) fun gtRtToEndOfText (pos, TXT{text,fi,...}) = let val FI{font,...} = fi val textWidth = Font.textWidth font (* getRange : int * rt list * rt list -> rt list*) fun getRange (pos, nil, ls) = rev ls | getRange (pos, (PT{x,y}, str) :: ts, ls) = let val len = String.size str in if pos >= len then getRange (pos - len, ts, ls) else let val (s1, s2) = strSplit (str, pos) val len' = String.size str in getRange (0, ts, (PT{x=x + textWidth s1,y=y}, s2) :: ls) end end in getRange (pos, text, nil) end (* val render : txt -> txt *) fun render (TXT{str,fi,rows,cols,wrap,text,chng}) = let val FI{font,fonta,fontd,maxc} = fi val width = maxc * cols val height = fonta + fontd val charPositions = Font.charPositions font val textWidth = Font.textWidth font val fndPos = findPos fun renderWrapped (nil, y, ts) = rev ts | renderWrapped (str :: ls, y, ts) = if textWidth str <= width then renderWrapped (ls, y + height, (PT{x=0,y=y}, str) :: ts) else let val ps = charPositions str val split = fndPos (width, tl ps, 0) val (s1, s2) = strSplit (str, split) in renderWrapped (s2 :: ls, y + height, (PT{x=0,y=y}, s1) :: ts) end fun renderUnwrapped (nil, y, ts) = rev ts | renderUnwrapped (str :: ls, y, ts) = renderUnwrapped (ls, y + height, (PT{x=0,y=y}, str) :: ts) val renderRec = if wrap then renderWrapped else renderUnwrapped in TXT{str = str, fi = fi, rows = rows, cols = cols, wrap = wrap, text = renderRec (strToLines str, fonta, nil), chng = chng} end (* val stText : string * txt -> txt *) fun stText (s, txt as TXT{str,fi,rows,cols,wrap,text,chng}) = let val {x_dim = W.DIM{nat=x,...}, y_dim = W.DIM{nat=y,...}} = gtDim txt val txt' = render (TXT{str=s,fi=fi,rows=rows,cols=cols, wrap=wrap,text=nil,chng=chng}) val {x_dim = W.DIM{nat=x',...}, y_dim = W.DIM{nat=y',...}} = gtDim txt' in if x <> x' orelse y <> y' then (send (chng, ()); txt') else txt' end (* val stRows : int * txt -> txt *) fun stRows (r, TXT{str,fi,rows,cols,wrap,text,chng}) = (if r > length text then send (chng, ()) else (); render (TXT{str=str,fi=fi,rows=r,cols=cols, wrap=wrap,text=nil,chng=chng})) (* val stCols : int * txt -> txt *) fun stCols (c, TXT{str,fi,rows,cols,wrap,text,chng}) = (send (chng, ()); render (TXT{str=str,fi=fi,rows=rows,cols=c, wrap=wrap,text=nil,chng=chng})) (* val stWrap : bool * txt -> txt *) fun stWrap (b, TXT{str,fi,rows,cols,wrap,text,chng}) = (send (chng, ()); render (TXT{str=str,fi=fi,rows=rows,cols=cols, wrap=b,text=nil,chng=chng})) (* val stFont : W.EXB.font * txt -> txt *) fun stFont (f, TXT{str,fi,rows,cols,wrap,text,chng}) = (send (chng, ()); render (TXT{str=str,fi=fontInfo f,rows=rows,cols=cols, wrap=wrap,text=nil,chng=chng})) (* val server : rqst chan * txt -> unit *) fun server (rqst, txt) = let fun loop (txt as TXT{str,fi,rows,cols,wrap,...}) = case recv rqst of GetText iv => (iPut (iv, str); loop txt) | SetText s => loop (stText (s, txt)) | GetFont iv => let val FI{font,...} = fi in iPut (iv, font); loop txt end | SetFont f => loop (stFont (f, txt)) | GetRows iv => (iPut (iv, rows); loop txt) | SetRows r => loop (stRows (r, txt)) | GetCols iv => (iPut (iv, cols); loop txt) | SetCols c => loop (stCols (c, txt)) | GetWrap iv => (iPut (iv, wrap); loop txt) | SetWrap b => loop (stWrap (b, txt)) | PtToPos (pt, iv) => (iPut (iv, pntToPos (pt, txt)); loop txt) | PosToPt (pos, iv) => (iPut (iv, posToPnt (pos, txt)); loop txt) | GetDim iv => (iPut (iv, gtDim txt); loop txt) | GetRt iv => (iPut (iv, gtRt txt); loop txt) | GetRtInRange (rng, iv) => (iPut (iv, gtRtInRange (rng, txt)); loop txt) | GetRtToEndOfLine (pos, iv) => (iPut (iv, gtRtToEndOfLine (pos, txt)); loop txt) | GetRtToEndOfText (pos, iv) => (iPut (iv, gtRtToEndOfText (pos, txt)); loop txt) in loop txt end (* val textRenderer : W.EXB.font -> int -> bool -> string -> textrenderer *) fun textRenderer (view, args) = let val attrs = W.findAttr (W.attrs (view, attrs, args)) val str = A.getString (attrs attr_text) val fi = fontInfo (A.getFont (attrs attr_font)) val rows = A.getInt (attrs attr_rows) val cols = A.getInt (attrs attr_columns) val wrap = A.getBool (attrs attr_linewrap) val reqc = channel() val modc = channel() val txt = TXT{str=str, fi=fi, rows=rows, cols=cols, wrap=wrap, text=nil, chng=modc} in XDebug.xspawn ("textRenderer", fn () => server (reqc, render txt)); TR{rqst=reqc, chng=modc} end fun get msg (TR{rqst,...}) = let val iv = iVar() in send (rqst, msg iv); iGet iv end fun set msg (TR{rqst,...}) arg = send (rqst, msg arg) val getText = get GetText val setText = set SetText val getFont = get GetFont val setFont = set SetFont val getRows = get GetRows val setRows = set SetRows val getColumns = get GetCols val setColumns = set SetCols val getLineWrap = get GetWrap val setLineWrap = set SetWrap fun ptToPos (TR{rqst,...}) pt = let val iv = iVar() in send (rqst, PtToPos (pt, iv)); iGet iv end fun posToPt (TR{rqst,...}) pos = let val iv = iVar() in send (rqst, PosToPt (pos, iv)); iGet iv end val getDim = get GetDim val getRt = get GetRt fun getRtInRange (TR{rqst,...}) rng = let val iv = iVar() in send (rqst, GetRtInRange (rng, iv)); iGet iv end (* val getRtToEndOfLine : textrenderer -> int -> rt *) fun getRtToEndOfLine (TR{rqst,...}) pos = let val iv = iVar() in send (rqst, GetRtToEndOfLine (pos, iv)); iGet iv end (* val getRtToEndOfText : textrenderer -> int -> rt *) fun getRtToEndOfText (TR{rqst,...}) pos = let val iv = iVar() in send (rqst, GetRtToEndOfText (pos, iv)); iGet iv end fun bufferEvt evt = let val ch = channel() fun full v = select [wrap (evt, full), wrap (sendEvt (ch, v), empty)] and empty () = full (sync evt) in XDebug.xspawn ("bufferEvt", fn () => empty()); recvEvt ch end fun evtOf (TR{chng,...}) = bufferEvt (recvEvt chng) end (* TextRenderer *)