(* graphical-view.sml *) (* Copyright (C) 2008 Alley Stoughton This file is part of crypto, a cryptogram encoder/decoder. See the file COPYING.txt for copying and usage restrictions *) (* graphical view *) structure View :> VIEW where type SymLinOrd.elem = Data.sym and type pds = Data.pds and type SymSet.set = Data.SymSet.set and type SymLexicon.lexicon = Data.SymLexicon.lexicon = struct open Data open CML structure A = Attrs structure EXB = EXeneBase structure LW = LowercaseWord structure SV = SyncVar structure W = Widget datatype primary_command = QuitPC | LexiconPC of sym_lexicon | EncodePC of msg | DecodePC of msg datatype primary_response = EncodeWordsNotInLexiconPR of (int * word)list | EncodeMultipleDecodingsPR | EncodeEncodingPR of msg | DecodeNoDecodingsPR | DecodeMultipleDecodingsPR datatype secondary_command = QuitSC | AbortSC | CheckSC | HintSC | ReplaceSC of sym * sym | UndoSC datatype secondary_response = CheckNotDecodableSR | CheckDecodedSR | CheckDecodableButNotDecodedSR | HintNotDecodableSR | HintDecodedSR | HintReplaceSR of sym * sym (* val printErr : string -> unit print string on standard error output *) fun printErr s = TextIO.output(TextIO.stdErr, s) (* val wordToStr : word -> string convert a word to a string *) fun wordToStr [b] = str b | wordToStr (b :: bs) = str b ^ wordToStr bs | wordToStr nil = raise Fail "cannot happen" (* val lineToStr : line -> string convert a line to a string *) fun lineToStr nil = "" | lineToStr [x] = wordToStr x | lineToStr (x :: xs) = wordToStr x ^ " " ^ lineToStr xs (* val msgToStr : msg -> string convert a message to a string *) fun msgToStr nil = "" | msgToStr (x :: xs) = lineToStr x ^ "\n" ^ msgToStr xs (* val pdsToStr : pds -> string convert a pds to a string, using lowercase letters for old symbols, and uppercase letters for new symbols *) fun pdsToStr(Old a) = str a | pdsToStr(New a) = str(Char.toUpper a) (* val pdwToStr : pdw -> string convert a pdw to a string, using lowercase letters for old symbols, and uppercase letters for new symbols *) fun pdwToStr [x] = pdsToStr x | pdwToStr (x :: xs) = pdsToStr x ^ pdwToStr xs | pdwToStr nil = raise Fail "cannot happen" (* val pdlToStr : pdl -> string convert a pdl to a string, using lowercase letters for old symbols, and uppercase letters for new symbols *) fun pdlToStr nil = "" | pdlToStr [x] = pdwToStr x | pdlToStr (x :: xs) = pdwToStr x ^ " " ^ pdlToStr xs (* val pdmToStr : pdm -> string convert a pdm to a string, using lowercase letters for old symbols, and uppercase letters for new symbols *) fun pdmToStr nil = "" | pdmToStr (x :: xs) = pdlToStr x ^ "\n" ^ pdmToStr xs (* val symSetToPredList : sym_set -> bool list convert a sym set to a list of booleans of length 26, where the 0th boolean is true/false depending upon whether #"a" is in the set, and the 1st corresponds to #"b", etc. *) fun symSetToPredList xs = let (* val toPred : int * char list -> bool list in a call toPred(n, xs), 0 <= n <= 26 and xs consists of lowercase letters in ascending order without repetition in a call toPred(n, x :: xs), chr(n + ord #"a") <= x *) fun toPred(n, nil) = if n = 26 then nil else false :: toPred(n + 1, nil) | toPred(n, x_xs as x :: xs) = if chr(n + ord #"a") = x then true :: toPred(n + 1, xs) else false :: toPred(n + 1, x_xs) in toPred(0, SymSet.toList xs) end (* val falsePredList : bool list a list of length 26 all of whose elements are false *) val falsePredList = symSetToPredList(SymSet.fromList[]) (* val sleep : int -> unit sleep for a specified number of milliseconds *) fun sleep n = sync(timeOutEvt(Time.fromMilliseconds n)) (* view data - channels used to allow functions of view to communicate with main thread of view *) type vd = {(* primaryInput sends to this to request a primary command *) primaryCommandChan : primary_command SV.ivar chan, (* secondaryInput sends to this to display a pdm and request a secondary command; the first sym_set is the old symbols of the pdm, and the second one is the new symbols of the pdm *) secondaryCommandChan : (pdm * sym_set * sym_set * secondary_command SV.ivar)chan, (* primaryOutput sends to this to display a primary response *) primaryResponseChan : primary_response chan, (* secondaryOutput sends to this to display a secondary response *) secondaryResponseChan : secondary_response chan, (* abortable sends to this to indicate that an abortable computation has been started *) abortableStartChan : unit chan, (* the checkAbort function declared by abortable sends (m, iVar) to this to indicate that m steps of an abortable computation have been completed, and to request that iVar be filled in with whether the user has asked that the computation be aborted *) abortableCheckChan : (IntInf.int * bool SV.ivar)chan, (* abortable sends (m, true) to this to indicate that an abortable computation has completed in m steps, and sends (m, false) to this to indicate that the computation was aborted after m steps *) abortableStopChan : (IntInf.int * bool)chan} fun primaryInput(vd as {primaryCommandChan, ...} : vd) = let val ivar : primary_command SV.ivar = SV.iVar() in send(primaryCommandChan, ivar); (vd, SV.iGet ivar) end fun secondaryInput(vd as {secondaryCommandChan, ...} : vd, pdm, olds, news) = let val ivar : secondary_command SV.ivar = SV.iVar() in send(secondaryCommandChan, (pdm, olds, news, ivar)); (vd, SV.iGet ivar) end fun primaryOutput(vd as {primaryResponseChan, ...} : vd, resp) = (send(primaryResponseChan, resp); vd) fun secondaryOutput(vd as {secondaryResponseChan, ...} : vd, resp) = (send(secondaryResponseChan, resp); vd) (* also see abortableServer *) type abort = vd * IntInf.int fun abortable(vd : vd, n, f) = let (* val checkAbort : abort -> abort * bool *) fun checkAbort(vd : vd, m) = if m > 0 andalso m mod (IntInf.fromInt n) = 0 then let val iVar = SV.iVar() val _ = send(#abortableCheckChan vd, (m, iVar)) in if SV.iGet iVar then ((vd, m), true) else ((vd, m + 1), false) end else ((vd, m + 1), false) val _ = send(#abortableStartChan vd, ()) in case f((vd, 0 : IntInf.int), checkAbort) of ((vd : vd, m), u, NONE) => (send(#abortableStopChan vd, (m, false)); (vd, u, NONE)) | ((vd, m), u, x) => (send(#abortableStopChan vd, (m, true)); (vd, u, x)) end (* widget data - see primary *) type widget_data = {messageSet : string -> unit, auxLabEvt : string event, auxSetActive : bool list -> unit, textGet : unit -> string, textSet : string -> unit, framedTextSetActive : bool -> unit, textAuxSet : string -> unit, secLabEvt : string event, secSetActive : bool list -> unit, letLabEvt : string event, letSetActive : bool list -> unit, delEvt : unit event, delFlushEvt : unit event} (* val quitSC : secondary_command SV.ivar * widget_data * (unit -> 'a) -> 'a the quit secondary command, called by secondary *) fun quitSC(iVar, {messageSet, textSet, textAuxSet, ...} : widget_data, primLoop) = (textSet ""; textAuxSet ""; SV.iPut(iVar, QuitSC); primLoop()) (* val abortSC : secondary_command SV.ivar * widget_data * (unit -> 'a) -> 'a the abort secondary command, called by secondary *) fun abortSC(iVar, {messageSet, textSet, textAuxSet, ...} : widget_data, primLoop) = (textSet ""; textAuxSet ""; SV.iPut(iVar, AbortSC); primLoop()) (* val checkSC : vd * secondary_command SV.ivar * widget_data * (unit -> 'a) * (unit -> 'a) -> 'a the check secondary command, called by secondary *) fun checkSC(vd : vd, iVar, {auxSetActive, auxLabEvt, messageSet, textSet, textAuxSet, ...} : widget_data, primLoop, secLoop) = (SV.iPut(iVar, CheckSC); case recv(#secondaryResponseChan vd) of CheckNotDecodableSR => (messageSet "pdm is not decodable"; auxSetActive[true, false]; sync auxLabEvt; secLoop()) | CheckDecodedSR => (messageSet "pdm is decoded"; auxSetActive[true, false]; sync auxLabEvt; textSet ""; textAuxSet ""; primLoop()) | CheckDecodableButNotDecodedSR => (messageSet "pdm is decodable but not decoded"; auxSetActive[true, false]; sync auxLabEvt; secLoop()) | _ => raise Fail "cannot happen") (* val hintSC : vd * secondary_command SV.ivar * widget_data * (unit -> 'a) * (unit -> 'a) -> 'a the hint secondary command, called by secondary *) fun hintSC(vd : vd, iVar, {auxSetActive, auxLabEvt, messageSet, textSet, textAuxSet, ...} : widget_data, primLoop, secLoop) = (SV.iPut(iVar, HintSC); case recv(#secondaryResponseChan vd) of HintNotDecodableSR => (messageSet "pdm is not decodable"; auxSetActive[true, false]; sync auxLabEvt; secLoop()) | HintDecodedSR => (messageSet "pdm is decoded"; auxSetActive[true, false]; sync auxLabEvt; textSet ""; textAuxSet ""; primLoop()) | HintReplaceSR(a, b) => (messageSet("replacing " ^ str a ^ " by " ^ str b); auxSetActive[true, false]; sync auxLabEvt; secLoop()) | _ => raise Fail "cannot happen") (* val replaceSC : pdm * sym_set * sym_set * secondary_command SV.ivar * widget_data * (unit -> 'a) * (pdm * sym_set * sym_set * secondary_command SV.ivar -> 'a) -> 'a the replace secondary command, called by secondary *) fun replaceSC(pdm, olds, news, iVar, {auxSetActive, auxLabEvt, messageSet, letLabEvt, letSetActive, ...} : widget_data, secLoop, secLoop') = (messageSet "replacing ..."; letSetActive(symSetToPredList olds); auxSetActive[false, true]; select [wrap(letLabEvt, fn x => (messageSet("replacing " ^ x ^ " by ..."); letSetActive(symSetToPredList(SymSet.minus(symbols, news))); auxSetActive[false, true]; select [wrap(letLabEvt, fn y => (messageSet("replacing " ^ x ^ " by " ^ y); auxSetActive[true, true]; case sync auxLabEvt of "OK" => (SV.iPut(iVar, ReplaceSC(String.sub(x, 0), String.sub(y, 0))); secLoop()) | "Cancel" => secLoop'(pdm, olds, news, iVar) | _ => raise Fail "cannot happen")), wrap(auxLabEvt, fn _ => (letSetActive falsePredList; secLoop'(pdm, olds, news, iVar)))])), wrap(auxLabEvt, fn _ => (letSetActive falsePredList; secLoop'(pdm, olds, news, iVar)))]) (* val undoSC : vd * secondary_command SV.ivar * widget_data * (primary_command SV.ivar -> 'a) * (pdm * sym_set * sym_set * secondary_command SV.ivar -> 'a) -> 'a undo secondary command, called by secondary *) fun undoSC(vd : vd, iVar, {messageSet, textSet, textAuxSet, ...} : widget_data, primLoop', secLoop') = (SV.iPut(iVar, UndoSC); select [wrap(recvEvt(#primaryCommandChan vd), fn iVar => (messageSet("nothing to undo, so returning to primary " ^ "command loop"); sleep 2000; textSet ""; textAuxSet ""; primLoop' iVar)), wrap(recvEvt(#secondaryCommandChan vd), fn x => secLoop' x)]) (* val secondary : vd * pdm * sym_set * sym_set * secondary_command SV.ivar * widget_data * (unit -> 'a) * (primary_command SV.ivar -> 'a) -> 'a secondary command loop, called by primary *) fun secondary(vd : vd, pdm, olds, news, iVar, widgetData as {messageSet, auxSetActive, textAuxSet, secLabEvt, secSetActive, delEvt, delFlushEvt, ...} : widget_data, primLoop, primLoop') = let (* val loop : unit -> 'a *) fun loop() = loop'(recv(#secondaryCommandChan vd)) (* val loop' : pdm * sym_set * sym_set * secondary_command SyncVar.ivar -> 'a *) and loop'(pdm, olds, news, iVar) = (sync delFlushEvt; secSetActive[true, true, true, true, true, true]; messageSet "select secondary command"; textAuxSet(pdmToStr pdm); select [wrap(secLabEvt, fn "Quit" => quitSC(iVar, widgetData, primLoop) | "Abort" => abortSC(iVar, widgetData, primLoop) | "Check" => checkSC(vd, iVar, widgetData, primLoop, loop) | "Hint" => hintSC(vd, iVar, widgetData, primLoop, loop) | "Replace" => replaceSC(pdm, olds, news, iVar, widgetData, loop, loop') | "Undo" => undoSC(vd, iVar, widgetData, primLoop', loop') | _ => raise Fail "cannot happen"), wrap(delEvt, fn () => quitSC(iVar, widgetData, primLoop))]) in loop'(pdm, olds, news, iVar) end (* val quitPC : primary_command SV.ivar * widget_data * (unit -> 'a) -> 'a the quit primary command, called by primary *) fun quitPC(iVar, {messageSet, ...} : widget_data, primLoop) = (SV.iPut(iVar, QuitPC); primLoop()) (* val lexiconPC : bool * primary_command SV.ivar * widget_data * (unit -> 'a) * (primary_command SV.ivar -> 'a) -> 'a the lexicon primary command, called by primary *) fun lexiconPC(retry, iVar, widgetData as {messageSet, auxLabEvt, auxSetActive, textGet, textSet, framedTextSetActive, textAuxSet, ...} : widget_data, primLoop, primLoop') = (if retry then messageSet "edit filename" else messageSet "enter filename"; framedTextSetActive true; auxSetActive[true, true]; case sync auxLabEvt of "OK" => (let val _ = framedTextSetActive false val filename = Aux.removeLeadingTrailingSpace(textGet()) val (lex, warns) = LW.processFile (SymLexicon.empty, fn (x, lex) => SymLexicon.add(explode x, lex), fn lex => lex, fn lex => lex, LW.initError, LW.wordError, LW.newlineError, LW.eofError) filename in if length warns = 0 then () else (messageSet "warning: non-words in lexicon"; textAuxSet (String.concat (map (fn (n, x) => ("line " ^ Int.toString n ^ ": \"" ^ x ^ "\"\n")) warns)); auxSetActive[true, false]; sync auxLabEvt; ()); textSet ""; textAuxSet ""; SV.iPut(iVar, LexiconPC lex); primLoop() end handle UnableToOpenFile => (messageSet "unable to open file"; auxSetActive[true, false]; sync auxLabEvt; textAuxSet ""; lexiconPC(true, iVar, widgetData, primLoop, primLoop'))) | "Cancel" => (framedTextSetActive false; textSet ""; primLoop' iVar) | _ => raise Fail "cannot happen") (* val abortableServer : vd * widget_data -> bool server to handle abortable computations, called by encode and decode; see abortable, which is function called by controller functor *) fun abortableServer(vd : vd, {auxLabEvt, auxSetActive, messageSet, textSet, ...} : widget_data) = let (* val abortSer : bool -> IntInf.int * bool *) fun abortSer aborted = select [wrap(auxLabEvt, fn _ => abortSer true), wrap(recvEvt(#abortableCheckChan vd), fn (m, iVar) => (SV.iPut(iVar, aborted); messageSet("completed " ^ IntInf.toString m ^ " steps ..."); abortSer aborted)), wrap(recvEvt(#abortableStopChan vd), fn x => x)] val _ = messageSet "computing ..." val _ = auxSetActive[false, true] val (m, b) = abortSer false val _ = auxSetActive[false, false] in if b then (messageSet("terminated after completing " ^ IntInf.toString m ^ " steps"); sleep 2000) else (messageSet("interrupted after completing " ^ IntInf.toString m ^ " steps"); sleep 2000); b end (* val getMessage : bool * primary_command SV.ivar * widget_data * (primary_command SV.ivar -> 'a) * (msg -> 'a) -> 'a called by encodePC and decodePC to get a message *) fun getMessage(retry, iVar, widgetData as {messageSet, auxLabEvt, auxSetActive, textGet, textSet, framedTextSetActive, textAuxSet, ...} : widget_data, primLoop', cont) = (if retry then messageSet "edit message" else messageSet "enter message"; framedTextSetActive true; auxSetActive[true, true]; case sync auxLabEvt of "OK" => let val _ = framedTextSetActive false val msgStr = textGet() val (msg, errs) = LW.processString (LW.initNormal, LW.wordNormal, LW.newlineNormal, LW.eofNormal, LW.initError, LW.wordError, LW.newlineError, LW.eofError) msgStr in if length errs = 0 then (textAuxSet ""; cont msg) else (textAuxSet (String.concat (map (fn (n, x) => ("line " ^ Int.toString n ^ ": \"" ^ x ^ "\"\n")) errs)); messageSet "message contains non-words"; auxSetActive[true, false]; sync auxLabEvt; getMessage(true, iVar, widgetData, primLoop', cont)) end | "Cancel" => (framedTextSetActive false; textSet ""; textAuxSet ""; primLoop' iVar) | _ => raise Fail "cannot happen") (* val encodePC : bool * vd * primary_command SV.ivar * widget_data * (unit -> 'a) * (primary_command SV.ivar -> 'a) -> 'a the encode primary command, called by primary *) fun encodePC(retry, vd, iVar, widgetData as {messageSet, auxLabEvt, auxSetActive, textSet, textAuxSet, framedTextSetActive, ...} : widget_data, primLoop, primLoop') = getMessage (retry, iVar, widgetData, primLoop', fn msg => (SV.iPut(iVar, EncodePC msg); select [wrap(recvEvt(#primaryResponseChan vd), fn EncodeWordsNotInLexiconPR ps => (messageSet "message has words not in lexicon"; textAuxSet (String.concat (map (fn (n, x) => "line " ^ Int.toString n ^ ": \"" ^ wordToStr x ^ "\"\n") ps)); auxSetActive[true, false]; sync auxLabEvt; encodePC(true, vd, recv(#primaryCommandChan vd), widgetData, primLoop, primLoop')) | _ => raise Fail "cannot happen"), wrap(recvEvt(#abortableStartChan vd), fn () => if abortableServer(vd, widgetData) then case recv(#primaryResponseChan vd) of EncodeMultipleDecodingsPR => (messageSet("message has " ^ "multiple decodings"); auxSetActive[true, false]; sync auxLabEvt; encodePC(true, vd, recv(#primaryCommandChan vd), widgetData, primLoop, primLoop')) | EncodeEncodingPR msg' => (messageSet "message encoding"; textAuxSet(msgToStr msg'); auxSetActive[true, false]; sync auxLabEvt; textSet ""; textAuxSet ""; primLoop()) | _ => raise Fail "cannot happen" else encodePC(true, vd, recv(#primaryCommandChan vd), widgetData, primLoop, primLoop'))])) (* val decodePC : bool * vd * primary_command SyncVar.ivar * widget_data * (unit -> 'a) * (primary_command SyncVar.ivar -> 'a) -> 'a the decode primary command, called by primary *) fun decodePC(retry, vd, iVar, widgetData as {messageSet, auxLabEvt, auxSetActive, ...}, primLoop, primLoop') = getMessage (retry, iVar, widgetData, primLoop', fn msg => (SV.iPut(iVar, DecodePC msg); recv(#abortableStartChan vd); if abortableServer(vd, widgetData) then select [wrap(recvEvt(#primaryResponseChan vd), fn DecodeNoDecodingsPR => (messageSet "message has no decodings"; auxSetActive[true, false]; sync auxLabEvt; decodePC(true, vd, recv(#primaryCommandChan vd), widgetData, primLoop, primLoop')) | DecodeMultipleDecodingsPR => (messageSet "message has multiple decodings"; auxSetActive[true, false]; sync auxLabEvt; decodePC(true, vd, recv(#primaryCommandChan vd), widgetData, primLoop, primLoop')) | _ => raise Fail "cannot happen"), wrap(recvEvt(#secondaryCommandChan vd), fn (pdm, olds, news, iVar) => secondary(vd, pdm, olds, news, iVar, widgetData, primLoop, primLoop'))] else decodePC(true, vd, recv(#primaryCommandChan vd), widgetData, primLoop, primLoop'))) (* val primary : string * Root.root * W.view * vd -> 'a the primary command loop *) fun primary(name, root, view, vd : vd) = let val attr_background = A.attr_background val attr_foreground = A.attr_foreground val attr_font = A.attr_font val defaultBackground = "white" val defaultForeground = "black" val attrSpecs = [(attr_background, A.AT_Color, A.AV_Str defaultBackground), (attr_foreground, A.AT_Color, A.AV_Str defaultForeground)] val attrs = W.findAttr(W.attrs(view, attrSpecs, nil)) val background = A.getColor(attrs attr_background) val foreground = A.getColor(attrs attr_foreground) val primButtonBar = ButtonBar.buttonBar (root, view, nil) ["Quit", "Lexicon", "Encode", "Decode"] val primLabEvt = ButtonBar.labEvtOf primButtonBar val primSetActive = ButtonBar.setActive primButtonBar val secButtonBar = ButtonBar.buttonBar (root, view, nil) ["Quit", "Abort", "Check", "Hint", "Replace", "Undo"] val secLabEvt = ButtonBar.labEvtOf secButtonBar val secSetActive = ButtonBar.setActive secButtonBar val auxButtonBar = ButtonBar.buttonBar (root, view, nil) ["OK", "Cancel"] val auxLabEvt = ButtonBar.labEvtOf auxButtonBar val auxSetActive = ButtonBar.setActive auxButtonBar val letButtonBar = ButtonBar.buttonBar (root, view, nil) (map str (explode "ABCDEFGHIJKLMNOPQRSTUVWXYZ")) val letLabEvt = wrap(ButtonBar.labEvtOf letButtonBar, String.map Char.toLower) val letSetActive = ButtonBar.setActive letButtonBar val text = TextWindow.textWindow(root, view, nil) val _ = TextWindow.setRows text 6 val _ = TextWindow.setColumns text 60 val _ = TextWindow.setActive text true val _ = TextWindow.setEditable text false val _ = TextWindow.setActiveBgColor text background val _ = TextWindow.setActiveFgColor text foreground val scrollArgs = [(Quark.quark "hsb", Attrs.AV_Bool true), (Quark.quark "vsb", Attrs.AV_Bool true)] val scrollText = ScrollPort.scrollPort (root, view, scrollArgs) (TextWindow.widgetOf text) val frameArgs = [(A.attr_borderWidth, A.AV_Int 2), (A.attr_relief, A.AV_Relief W.Flat)] val framedText = Frame.frame (root, view, frameArgs) (ScrollPort.widgetOf scrollText) val _ = Frame.setColor framedText (SOME background) (* val frameTextSetActive : bool -> unit *) fun framedTextSetActive b = (Frame.setColor framedText (SOME(if b then foreground else background)); TextWindow.setEditable text b) (* val textGet : unit -> string *) fun textGet() = TextWindow.getText text (* val textSet : string -> unit *) fun textSet s = (TextWindow.setCaretPosition text 0; TextWindow.setText text s) val textAux = TextWindow.textWindow(root, view, nil) val _ = TextWindow.setRows textAux 6 val _ = TextWindow.setColumns textAux 60 val _ = TextWindow.setActive textAux true val _ = TextWindow.setEditable textAux false val _ = TextWindow.setActiveBgColor textAux background val _ = TextWindow.setActiveFgColor textAux foreground val scrollTextAux = ScrollPort.scrollPort (root, view, scrollArgs) (TextWindow.widgetOf textAux) val framedTextAux = Frame.frame (root, view, frameArgs) (ScrollPort.widgetOf scrollTextAux) val _ = Frame.setColor framedTextAux (SOME background) (* val textAuxSet : string -> unit *) fun textAuxSet s = (TextWindow.setCaretPosition textAux 0; TextWindow.setText textAux s) val messageWidth = 60 val messageArgs = [(A.attr_width, A.AV_Int messageWidth), (A.attr_halign, A.AV_HAlign W.HCenter)] val message = Label.label(root, view, messageArgs) (* val messageSet : string -> unit *) fun messageSet s = Label.setLabel message (Label.Text s) val pad = 5 val padGlue = Box.Glue{nat = pad, min = pad, max = SOME pad} val box = Box.HzCenter [padGlue, Box.VtCenter [padGlue, Box.WBox(ButtonBar.widgetOf primButtonBar), padGlue, Box.WBox(ButtonBar.widgetOf secButtonBar), padGlue, Box.WBox(ButtonBar.widgetOf auxButtonBar), padGlue, Box.WBox(ButtonBar.widgetOf letButtonBar), padGlue, padGlue, Box.WBox(Frame.widgetOf framedText), padGlue, padGlue, Box.WBox(Frame.widgetOf framedTextAux), padGlue, padGlue, Box.WBox(Label.widgetOf message), padGlue], padGlue] val layout = Box.layout (root, view, nil) box val shellArgs = [(A.attr_title, A.AV_Str name), (A.attr_iconName, A.AV_Str name)] val shell = Shell.shell (root, view, shellArgs) (Box.widgetOf layout) val (delEvt, delFlushEvt) = FilterEvt.filterEvt (fn _ => true) (Shell.deleteEvent shell) val _ = Shell.init shell val widgetData : widget_data = {messageSet = messageSet, auxLabEvt = auxLabEvt, auxSetActive = auxSetActive, textGet = textGet, textSet = textSet, framedTextSetActive = framedTextSetActive, textAuxSet = textAuxSet, secLabEvt = secLabEvt, secSetActive = secSetActive, letLabEvt = letLabEvt, letSetActive = letSetActive, delEvt = delEvt, delFlushEvt = delFlushEvt} (* val loop : unit -> 'a *) fun loop() = loop'(recv(#primaryCommandChan vd)) (* val loop' : primary_command SV.ivar -> 'a *) and loop' iVar = (sync delFlushEvt; primSetActive[true, true, true, true]; messageSet "select primary command"; select [wrap(primLabEvt, fn "Quit" => quitPC(iVar, widgetData, loop) | "Lexicon" => lexiconPC(false, iVar, widgetData, loop, loop') | "Encode" => encodePC(false, vd, iVar, widgetData, loop, loop') | "Decode" => decodePC(false, vd, iVar, widgetData, loop, loop') | _ => raise Fail "cannot happen"), wrap(delEvt, fn () => quitPC(iVar, widgetData, loop))]) in loop() end (* command line argument specifications *) val optSpec = [(Styles.OPT_NAMED("display"), "-display", Styles.OPT_SEPARG, Attrs.AT_Str), (Styles.OPT_NAMED("name"), "-name", Styles.OPT_SEPARG, Attrs.AT_Str), (Styles.OPT_RESSPEC("*background"), "-background", Styles.OPT_SEPARG, Attrs.AT_Str), (Styles.OPT_RESSPEC("*background"), "-bg", Styles.OPT_SEPARG, Attrs.AT_Str), (Styles.OPT_RESSPEC("*foreground"), "-foreground", Styles.OPT_SEPARG, Attrs.AT_Str), (Styles.OPT_RESSPEC("*foreground"), "-fg", Styles.OPT_SEPARG, Attrs.AT_Str), (Styles.OPT_RESSPEC("*font"), "-font", Styles.OPT_SEPARG, Attrs.AT_Font), (Styles.OPT_RESSPEC("*font"), "-fn", Styles.OPT_SEPARG, Attrs.AT_Font)] (* application's default resources *) val appResources : string list = ["*font: 10x20", "*background: white", "*foreground: black"] (* command-line options *) val options = ["", " where options are:", "", " -display DISPLAY", " -name APPLICATION-NAME", " -background BACKGROUND-COLOR", " -bg BACKGROUND-COLOR", " -foreground FOREGROUND-COLOR", " -fg FOREGROUND-COLOR", " -font FONT", " -fn FONT"] (* val start : string * string list * (vd -> vd) -> 'a *) fun start(cmd, args, f) = let val _ = XDebug.init["-/ThreadWatcher/"] val (optDB, unArgs) = Widget.parseCommand optSpec args val _ = if null unArgs then () else (printErr(cmd ^ ": usage: " ^ cmd ^ " OPTIONS\n"); app (fn s => printErr(cmd ^ ": " ^ s ^ "\n")) options; RunCML.shutdown OS.Process.failure) val displayNameOpt = case Widget.findNamedOptStrings optDB (Styles.OPT_NAMED("display")) of [] => NONE | s :: _ => SOME s val root = W.mkRoot(GetDpy.getDpy displayNameOpt) handle EXB.BadAddr _ => (printErr(cmd ^ ": unable to open display: " ^ (case displayNameOpt of NONE => "[default]" | SOME s => s) ^ "\n"); RunCML.shutdown OS.Process.failure) val name = case Widget.findNamedOpt optDB (Styles.OPT_NAMED("name")) root of [] => Aux.lastPartOfPath cmd | Attrs.AV_Str s :: _ => s | _ => raise Fail "cannot happen" val appStyle = Widget.styleFromStrings(root, appResources) handle _ => (printErr(cmd ^ ": bad application resource database\n"); Widget.delRoot root; RunCML.shutdown OS.Process.failure) val xrdStyle = Widget.styleFromXRDB root handle _ => (printErr(cmd ^ ": bad X server resource database\n"); Widget.delRoot root; RunCML.shutdown OS.Process.failure) val argStyle = Widget.styleFromOptDb(root, optDB) handle _ => (printErr(cmd ^ ": bad command line arguments resource " ^ " database\n"); Widget.delRoot root; RunCML.shutdown OS.Process.failure) val mainStyle = Widget.mergeStyles(argStyle, Widget.mergeStyles(xrdStyle, appStyle)) val styleView = Styles.mkView{name = Styles.styleName[name], aliases = [Styles.styleName["Crypto"]]} val view = (styleView, mainStyle) val vd = {primaryCommandChan = channel(), secondaryCommandChan = channel(), primaryResponseChan = channel(), secondaryResponseChan = channel(), abortableStartChan = channel(), abortableCheckChan = channel(), abortableStopChan = channel()} in spawn(fn () => primary(name, root, view, vd)); (* main thread of view *) f vd; W.delRoot root; RunCML.shutdown OS.Process.success end fun run(cmd, args, f) = RunCML.doit(fn () => start(cmd, args, f), NONE) end;