Root functor: Board.oz

### Root functor: `Board.oz`

Source File

>     local

>        PickleCompressionLevel = 9

>        local
>           InitServer = {NewName}
>        in
>           class Server
>              attr
>                 port close serve

>              meth !InitServer(?Port)
>                 proc {Serve X|Xs}
>                    {@serve X}
>                    {Serve Xs}
>                 end
>                 Stream
>                 CloseException = {NewName}
>              in
>                 proc {@close}
>                    raise CloseException end
>                 end
>                 {NewPort Stream Port}
>                 @port  = Port
>                 @serve = self
>                 thread
>                    try
>                       {Serve Stream}
>                    catch
>                       !CloseException then skip
>                    end
>                 end
>              end
>           end

>           fun {NewServer Class Init}
>              Port
>              Object = {New Class InitServer(Port)}
>           in
>              {Object Init}
>              Port
>           end

>        end

>        proc {NewAgenda ?Port ?Connect}
>           Stream
>        in
>           {NewPort Stream Port}
>           proc {Connect P}
>              thread
>                 {ForAll Stream proc {$ M} {Send P M} end}
>              end
>           end
>        end

>        fun {NewBoardFunctor IsMaster Ticket User}

>           ArgSpec = record(master(single type:bool default:IsMaster)
>                            ticket(single type:atom default:Ticket)
>                            user(single type:atom   default:User))

>        in

>           functor

>           import
>              Tk
>              TkTools
>              Connection
>              OS
>              Application
>              Pickle

>           define

>              Args = {Application.getCmdArgs ArgSpec}

>              proc {SendApplet FileName Subject To}
>                 if
>                    {OS.system ('metasend -b -e base64 -f '#FileName#
>                                ' -m application/x-oz-application'#
>                                ' -s "'#Subject#'" -t '#To)}\=0
>                 then
>                    raise failed(mail) end
>                 end
>              end

>              class Board from Server
>                 attr
>                    agenda connect

>                 meth init
>                    {NewAgenda @agenda @connect}
>                 end

>                 meth newWindow($)
>                    Connect = @connect % Don't pass reference to object
>                 in
>                    proc {$ Tk Desc}
>                       {NewServer Window init(Tk
>                                              {AdjoinAt Desc
>                                               agenda @agenda}
>                                              Connect) _}
>                    end
>                 end

>                 meth newTool(Label BClass WClass)
>                    T = {NewServer Tool init(BClass @agenda)}
>                 in
>                    {Send @agenda newTool(Label T WClass)}
>                 end

>                 meth newUser(UserId Name)
>                    {Send @agenda newUser(UserId Name)}
>                 end

>                 meth deleteUser(UserId)
>                    {Send @agenda deleteUser(UserId)}
>                 end

>                 meth close
>                    {Send @agenda shutdown}
>                    {@close}
>                 end
>              end

>              class Tool from Server
>                 attr
>                    bClass  agenda

>                 meth init(BClass Agenda) % invoked by Board
>                    @bClass  = BClass
>                    @agenda  = Agenda
>                 end

>                 meth newBObj(X Y) % invoked by Window
>                    {NewServer @bClass init(@agenda @port X Y) _}
>                 end
>              end

>              class BObject
>                 from Server
>                    %% virtual, needs attributes kind, props, dx, dy
>                 attr
>                    agenda
>                    updating: false

>                 meth init(Agenda Tool X Y) % invoked by Tool
>                    Message = create(@kind X Y X+@dx Y+@dy
>                                     {List.toRecord o {self GetProps($)}})
>                 in
>                    @agenda = Agenda
>                    {Send @agenda newWObj(@port Tool Message)}
>                 end

>                 meth requestUpdate(Window) % invoked by Window
>                    if @updating then {Send Window rejectRequest}
>                    else
>                       updating <- true
>                       {Send Window grantUpdate({self GetProps($)} @port)}
>                    end
>                 end

>                 meth requestClose(Window) % invoked by Window
>                    if @updating then {Send Window rejectRequest}
>                    else
>                       {Send @agenda closeWObj(@port Window)}
>                       {@close}
>                    end
>                 end

>                 meth update(NewProps) % invoked by Dialog
>                    {ForAll NewProps proc {$ A#V} A <- V end}
>                    {Send @agenda updateWObj(@port NewProps)}
>                    updating <- false
>                 end

>                 meth GetProps($)
>                    {Map @props fun {$ A} A#@A end}
>                 end
>              end

>              class Window from Server
>                 attr
>                    tk  top  bar  radio  canvas
>                    tool page1 page2
>                    BObj2WObj:   nil
>                    Tool2WClass: nil
>                    Name2Label:  nil
>                    BGColor:     ivory
>                    Busy:        false
>                    MyDialog:    nil

>                 meth init(Tk Desc ConnectToAgenda) % invoked by Board
>                    proc {ActionNewBObj X Y}
>                       {Send @port NewBObj(X Y)}
>                    end
>                    proc {ActionDelete}
>                       {Send Desc.agenda deleteUser(Desc.user)}
>                       {Send @port   Close}
>                       if {HasFeature Desc close} then
>                          {Desc.close}
>                       end
>                    end
>                    Title   = {CondSelect Desc title 'Drawing Board'}
>                    TkTools = Tk.tools
>                 in
>                    @tool   = {NewPort _}
>                    @tk     = Tk
>                    @top    = {New Tk.toplevel
>                               tkInit(title:Title delete:ActionDelete
>                                      withdraw:true)}
>                    @page1  = {New TkTools.textframe tkInit(parent:@top text:'Tools')}
>                    @radio  = {New Tk.variable tkInit}
>                    @page2  = {New TkTools.textframe tkInit(parent:@top text:'Users')}
>                    @canvas = {New Tk.canvas
>                               tkInit(parent:@top bd:2 relief:sunken
>                                      width:300 height:300 bg:@BGColor)}
>                    {@canvas tkBind(event:  '<1>'
>                                    args:   [int(x) int(y)]
>                                    action: ActionNewBObj)}
>                    {Tk.batch [grid(@page1  row:0 column:0 pady:4 sticky:ew)
>                               grid(@page2  row:1 column:0 pady:4 sticky:ew)
>                               grid(@canvas row:0 column:1 sticky:sn padx:2 pady:2
>                                    rowspan:4)
>                               grid({New Tk.button
>                                     tkInit(parent: @top
>                                            text:  'Mail Applet'
>                                            action: Desc.mail)}
>                                    sticky:ew pady:4
>                                    row:2 column:0)
>                               grid({New Tk.button
>                                     tkInit(parent: @top
>                                            text:  'Save Applet'
>                                            action: Desc.save)}
>                                    sticky:ew pady:4
>                                    row:3 column:0)
>                               update(idletasks)
>                               wm(deiconify @top)]}
>                    {ConnectToAgenda @port}
>                 end

>                 meth newTool(Label Tool WClass) % invoked by Board
>                    proc {ActionSelectTool}
>                       {Send @port SelectTool(Tool)}
>                    end
>                    C|S    = {VirtualString.toString Label}

>                    Button = {New @tk.radiobutton
>                              tkInit(parent: @page1.inner
>                                     text:   {Char.toUpper C}|S
>                                     anchor: w
>                                     bg:'#b9b9b9'
>                                     var:    @radio
>                                     value:  Label
>                                     relief: groove
>                                     bd:     2
>                                     action: ActionSelectTool)}
>                 in
>                    {@tk.send grid(Button sticky:sew padx:2 pady:2)}
>                    {self Put(Tool2WClass Tool WClass)}
>                 end

>                 meth newUser(UserId Name) % invoked by Board
>                    Label = {New @tk.label
>                             tkInit(parent: @page2.inner
>                                    text:   Name
>                                    anchor: w
>                                    bg:     white
>                                    bd:     2)}
>                 in
>                    {@tk.send grid(Label sticky:sew padx:2 pady:2)}
>                    {self Put(Name2Label UserId Label)}
>                 end

>                 meth deleteUser(UserId)
>                    {{self Get(Name2Label UserId $)} tkClose}
>                    {self Delete(Name2Label UserId)}
>                 end

>                 meth shutdown % invoked by Board
>                    if @MyDialog \= nil then {Send @MyDialog close} end
>                    {@top tkClose}
>                    {@close}
>                 end

>                 meth NewBObj(X Y) % invoked by User <1>
>                    {Send @tool newBObj(X Y)}
>                 end

>                 meth updateBObj(BObj) % invoked by User <2>
>                    if @Busy then {self Flash(black)} else
>                       {self MkBusy}
>                       {Send BObj requestUpdate(@port)}
>                    end
>                 end

>                 meth closeBObj(BObj) % invoked by User <3>
>                    if @Busy then  {self Flash(black)} else
>                       {self MkBusy}
>                       {Send BObj requestClose(@port)}
>                    end
>                 end

>                 meth SelectTool(Tool) % invoked by User <1>
>                    tool <- Tool
>                 end

>                 meth Close % invoked by User <1>
>                    if @Busy then  {self Flash(black)}  else
>                       {@top tkClose}
>                       {@close}
>                    end
>                 end

>                 meth newWObj(BObj Tool Message) % invoked by BObject through agenda
>                    WObj = {New {self Get(Tool2WClass Tool $)}
>                            init(@tk @port @canvas BObj Message)}
>                 in
>                    {self Put(BObj2WObj BObj WObj)}
>                 end

>                 meth updateWObj(BObj Props) % invoked by BObject through agenda
>                    {{self Get(BObj2WObj BObj $)} update(Props)}
>                 end

>                 meth closeWObj(BObj Window) % invoked by BObject through agenda
>                    if Window == @port then {self MkIdle} end
>                    {{self Get(BObj2WObj BObj $)} close}
>                 end

>                 meth grantUpdate(Old BObj) % invoked by BObject
>                    MyDialog <- {NewServer Dialog init(@tk @port Old BObj)}
>                 end

>                 meth rejectRequest % invoked by BObject
>                    {self Flash(red)}
>                    {self MkIdle}
>                 end

>                 meth dialogClosed % invoked by Dialog
>                    MyDialog <- nil
>                    {self MkIdle}
>                 end

>                 meth Put(A K V)
>                    A <- K#V | @A
>                 end

>                 meth Get(A K $)
>                    {LookUp @A K}
>                 end

>                 meth Delete(A K)
>                    A <- {Remove @A K}
>                 end

>                 meth MkBusy
>                    Busy <- true
>                    {self ChangeColor(thistle)}
>                 end

>                 meth MkIdle
>                    Busy <- false
>                    {self ChangeColor(ivory)}
>                 end

>                 meth ChangeColor(Color)
>                    {@canvas tk(configure(bg:Color))}
>                    BGColor <- Color
>                 end

>                 meth Flash(Color)
>                    OldColor = @BGColor
>                 in
>                    {self ChangeColor(Color)}
>                    {Delay 200}
>                    {self ChangeColor(OldColor)}
>                 end
>              end

>              fun {LookUp K#I|KIr GK}
>                 if K==GK then I else {LookUp KIr GK} end
>              end

>              fun {Remove KIs DK}
>                 case KIs of nil then nil
>                 [] KI|KIr then K#_=KI in
>                    if K==DK then KIr else KI|{Remove KIr DK} end
>                 end
>              end

>              fun {GetHostName}
>                 UTS = {OS.uName}
>              in
>                 UTS.nodename
>              end

>              class WObject
>                 attr
>                    canvas tag

>                 meth init(Tk Window Canvas BObj Message) % invoked by Window
>                    proc {ActionUpdate} {Send Window updateBObj(BObj)} end
>                    proc {ActionClose} {Send Window closeBObj(BObj)} end
>                 in
>                    @canvas = Canvas
>                    @tag  = {New Tk.canvasTag tkInit(parent:Canvas)}
>                    {Canvas tk(Message o(tag:@tag))}
>                    {@tag tkBind(event:'<2>' action: ActionUpdate)}
>                    {@tag tkBind(event:'<3>' action: ActionClose)}
>                 end

>                 meth update(Props) % invoked by Window on request of BObject
>                    {@canvas tk({List.toRecord itemconfigure (1#@tag|Props)})}
>                 end

>                 meth close % invoked by Window on request of BObject
>                    {@tag tk(delete)}
>                 end
>              end

>              class Dialog from Server
>                 attr
>                    top window entries oldProps bObj

>                 meth init(Tk Window OldProps BObj) % invoked by Window
>                    proc {ActionOk}
>                       {Send @port Ok}
>                    end
>                    proc {ActionCancel}
>                       {Send @port Cancel}
>                    end
>                    @window  = Window
>                    @oldProps= OldProps
>                    @bObj    = BObj
>                    @top     = {New Tk.toplevel
>                                tkInit(title:'Object Attributes' delete:ActionCancel
>                                       withdraw:true)}
>                    {@top tkWM(geometry '+'#{Tk.returnInt winfo(pointerx @top)}+5#
>                               '+'#{Tk.returnInt winfo(pointery @top)}+10)}
>                    @entries = {List.mapInd @oldProps
>                                fun {$ I A#V}
>                                   L = {New Tk.label
>                                        tkInit(parent:@top text:A#':' anchor:w)}
>                                   E = {New Tk.entry
>                                        tkInit(parent:@top width:10 bg:white)}
>                                in
>                                   {E tk(insert 0 V)}
>                                   {Tk.send grid(row:I L E sticky:w padx:4 pady:4)}
>                                   A#E
>                                end}
>                    OkButton     = {New Tk.button
>                                    tkInit(parent:@top  text:'Okay' action: ActionOk)}
>                 in
>                    {Tk.send grid(row:{Length @entries}+1 columnspan:2 pady:10 OkButton)}
>                    {@top tkWM(deiconify)}
>                 end

>                 meth close  % invoked by Window
>                    {@top tkClose}
>                    {@close}
>                 end

>                 meth Ok  % invoked by User <1>
>                    NewProps = {Map @entries fun {$ A#E} A # {E tkReturn(get $)} end}
>                 in
>                    {Send @bObj update(NewProps)}
>                    {Send @window dialogClosed}
>                    {self close}
>                 end

>                 meth Cancel  % invoked by User <1>
>                    {Send @bObj update(@oldProps)}
>                    {Send @window dialogClosed}
>                    {self close}
>                 end
>              end

>              class Circle from BObject
>                 attr
>                    kind:  oval
>                    props: [fill width]
>                    dx:    20
>                    dy:    20
>                    fill:   red
>                    width:  1
>              end

>              class Square from Circle
>                 attr
>                    kind: rectangle
>                    fill: blue
>              end

>              class HBar from Square
>                 attr
>                    dy:   4
>                    fill: orange
>              end

>              class VBar from Square
>                 attr
>                    dx:   4
>                    fill: green
>              end

>              class Arc from Circle
>                 attr
>                    kind:   arc
>                    props:  [fill start extent]
>                    fill:   yellow
>                    start:  22.5
>                    extent: 315
>              end

>              proc {MailBoard}
>                 FN = {OS.tmpnam}

>                 To

>                 T = {New Tk.toplevel tkInit}
>                 L = {New Tk.label  tkInit(parent:T text:'To: ')}
>                 E = {New Tk.entry  tkInit(parent:T width:20)}
>                 B = {New Tk.button tkInit(parent:T text:'Send'
>                                           action: proc {$}
>                                                      To = {E tkReturnAtom(get $)}
>                                                      {T tkClose}
>                                                   end)}
>                 {Tk.batch [pack(L E side:left pady:1#m padx:1#m)
>                            pack(B side:bottom pady:2#m)
>                            focus(E)]}

>              in

>                 {Wait To}

>                 {Pickle.saveCompressed
>                  {NewBoardFunctor false Ticket To} FN PickleCompressionLevel}

>                 try
>                    {SendApplet FN 'Oz Drawing Board' To}
>                 catch _ then
>                    D={New TkTools.error
>                       tkInit(text: ('Could not send mail. Please check whether '#
>                                     'metamail package is installed properly.'))}
>                 in
>                    {Wait D.tkClosed}
>                 end

>                 {OS.unlink FN}
>              end

>              proc {SaveBoard}
>                 case {Tk.return
>                       tk_getSaveFile(filetypes: q(q('Oz Applications'
>                                                     '.oza')
>                                                   q('All files'
>                                                     '*')))}
>                 of nil then skip
>                 [] S then
>                    {Pickle.saveCompressed
>                     {NewBoardFunctor false Ticket 'Saved'}
>                     S PickleCompressionLevel}
>                 end
>              end

>              Ticket B

>              UserId = {NewName}

>              if Args.master then
>                 B      = {NewServer Board init}
>                 Ticket = {New Connection.gate init(B $) _}
>              else
>                 Ticket = Args.ticket
>                 B      = {Connection.take Ticket}
>              end

>              {Wait Tk}
>              {Wait TkTools}

>              {{Send B newWindow($)} {AdjoinAt Tk tools TkTools}
>               d(title: 'Drawing Board'#'@'#{GetHostName}
>                 close: proc {$}
>                           {Application.exit 0}
>                        end
>                 mail:  MailBoard
>                 save:  SaveBoard
>                 user:  UserId)}

>              {Send B newUser(UserId Args.user)}

>              if Args.master then
>                 {Send B newTool(circle Circle WObject)}
>                 {Send B newTool(square Square WObject)}
>                 {Send B newTool(hbar HBar WObject)}
>                 {Send B newTool(vbar VBar WObject)}
>                 {Send B newTool(arc Arc WObject)}
>              end

>           end

>        end

>     in

>        {NewBoardFunctor true '' master}

>     end