[cells-devel] Celtk/cells: No Widgets! Help!
Frank Goenninger
fgoenninger at prion.de
Thu Apr 13 20:45:05 UTC 2006
Hi again ...
With substantial help I was able to get some more stuff to work as
expected. Now I am struggling with the fact that the menubar does
indeed have the menus I installed but the few widgets I placed into
the window simply don't appear...
Hmm - well, yes, why?? (As always, there's a FRGO placed here and there)
How do I debug what is being sent to wish ?
Thx for any inputs.
Frank
---
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: celtk-user; -*-
(in-package :cl-user)
(eval-when (:load-toplevel :compile-toplevel :execute)
#+asdf (progn
#-cells (asdf:operate 'asdf:load-op :cells)
#-Celtk (asdf:operate 'asdf:load-op :Celtk)
))
(in-package :celtk-user)
(defparameter *psu-rc-app* nil
"The instance of the PSU Remote Control application.")
;; BASE CLASS FOR APPLICATIONS
(defmodel application ()
(( .md-value :cell t :accessor view :initform (c-in
nil) :initarg :view )
( name :cell t :accessor name :initform (c-in
nil) :initarg :name )
( status :cell t :accessor status :initform (c-
in :disabled) :initarg :status)
))
;(defmethod initialize-instance :after ((self application) &key)
; (incf (nr-instances self))) - does not work ...
(defmodel application-object (family)
(( .md-name :cell t :accessor id :initform (c-
in :unknown) :initarg :id )))
;; PUSHBUTTON, SIGNAL-LAMP, PUSHBUTTON-WITH-SIGNAL-LAMP MODELS
(defmodel pushbutton (application-object)
(( .md-value :cell t
:accessor pb-state
:initform (c? (if (^pressed)
(on-off-toggle .cache)
(initial-pb-state self)))
:initarg :pb-state )
( initial-pb-state :cell nil
:initform :off
:initarg :initial-pb-state
:reader initial-pb-state )
( pressed :cell :ephemeral
:accessor pressed
:initform (c-in nil))))
(defmacro mk-pushbutton (&rest initargs)
`(make-instance 'pushbutton
:fm-parent *parent*
, at initargs))
;(defmacro push-the-button (button-id)
; `(setf (fm^v ,button-id) :pressed))
(defmodel signal-lamp (application-object)
((lamp-state :cell t
:accessor lamp-state
:initform (c? (if (^switched)
(not .cache)
(initial-lamp-state self)))
:initarg :lamp-state )
( initial-lamp-state :cell nil
:initform :off
:initarg :initial-lamp-state
:reader initial-lamp-state )
( switched :cell :ephemeral
:accessor switched
:initform (c-in nil))))
(defmacro mk-signal-lamp (&rest initargs)
`(make-instance 'signal-lamp
:fm-parent *parent*
, at initargs))
(defmodel pushbutton-with-signal-lamp (pushbutton signal-lamp)
())
(defmacro mk-pushbutton-with-signal-lamp (&rest initargs)
`(make-instance 'pushbutton-with-signal-lamp
:fm-parent *parent*
, at initargs))
;; PSU-APP-RC MODEL
(defun control-panel ()
(list
;; SIGNAL LAMPS
;; Mains signal lamp
(mk-signal-lamp :id :mains-lamp
;:lamp-state (cr-mains-lamp-state)
)
;; OPER signal lamp
(mk-signal-lamp :id :oper-lamp
;:lamp-state (cr-oper-lamp-state)
)
;; TEST signal lamp
(mk-signal-lamp :id :test-lamp
;:lamp-state (cr-test-lamp-state)
)
;; FAIL signal lamp
(mk-signal-lamp :id :fail-lamp
;:lamp-state (cr-fail-lamp-state)
)
;; PUSH BUTTONS AND LAMPS
;; Oper mode pushbutton with lamp
(mk-pushbutton-with-signal-lamp :id :oper-mode-pb
:initial-pb-state :off
:lamp-state (c? (if (^pressed)
(^pb-state)
(initial-lamp-state self)))
)
;; Test mode pushbutton with lamp
(mk-pushbutton-with-signal-lamp :id :test-mode-pb
:initial-pb-state :off
;:lamp-state (c? (^pb-state))
)
;; Ua-enable pushbutton with lamp
(mk-pushbutton-with-signal-lamp :id :Ua-enable-pb
:initial-pb-state :off)
;; Ug1 pushbutton with lamp
(mk-pushbutton-with-signal-lamp :id :Ug1-pb
:initial-pb-state :off)
;; Ug2 pushbutton with lamp
(mk-pushbutton-with-signal-lamp :id :Ug2-pb
:initial-pb-state :off)
;; Uh pushbutton with lamp
(mk-pushbutton-with-signal-lamp :id :Uh-pb
:initial-pb-state :off)
;; Uh pushbutton with lamp
(mk-pushbutton-with-signal-lamp :id :Uh-pb
:initial-pb-state :off)
)
)
(defmodel psu-rc-app (application)
(
;; Mains status (may have several vaklues, :ok indicates OK ;-)
( mains-status :cell t :accessor mains-status :initform (c-in nil)
:initarg :mains-status )
;; Operate status: eitehr :operate-mode or :test-mode
( operate-status :cell t :accessor operate-status :initform (c-
in nil)
:initarg :operate-status )
;; RS232C port
;; As soon as the port name is set try to read data from this port
;; DARC stands for Device and Application Remote Control
( darc-rs232c-port :cell t :accessor darc-rs232c-port
:initform (c-in nil)
:initarg :darc-rs232c-port )
;; Voltage and current values to be
displayed Units
( Ua :cell t :accessor Ua :initform (c-in
nil) :initarg :Ua ) ; [ V ]
( Ia :cell t :accessor Ia :initform (c-in
nil) :initarg :Ia ) ; [ A ]
( Uh :cell t :accessor Uh :initform (c-in
nil) :initarg :Uh ) ; [ V ]
( Ih :cell t :accessor Ih :initform (c-in
nil) :initarg :Ih ) ; [ A ]
( Ug1 :cell t :accessor Ug1 :initform (c-in
nil) :initarg :Ug1 ) ; [ V ]
( Ig1 :cell t :accessor Ig1 :initform (c-in
nil) :initarg :Ig1 ) ; [ mA ]
( Ug2 :cell t :accessor Ug2 :initform (c-in
nil) :initarg :Ug2 ) ; [ V ]
( Ig2 :cell t :accessor Ig2 :initform (c-in
nil) :initarg :Ig2 ) ; [ mA ]
)
)
(defmodel rs232c-port (window) ; needs to be a widget to get a
; timer easily ;-)
(( status :accessor status
:cell t
:initform (c-in :not-connected))
( device-name :accessor device-name
:cell t
:initform (c-in nil)
:initarg :device-name ))
(:default-initargs
:id :darc-port
:timers (c? (list
(make-instance 'timer
:state (c-in :off)
:repeat t
:delay 10000 ; 10 s delay
:action (lambda (timer)
(declare (ignore timer))
(let ((status (status (darc-rs232c-port *psu-rc-app*)))
(device-name (device-name (darc-rs232c-port *psu-rc-app*))))
(if (and (eq status
:not-connected)
device-name )
(connect-to-darc device-name)))))))))
(defun connect-to-darc (device-name)
(format t "~%*** connect-to-darc been called for port ~a ...~&"
device-name)
(when device-name
(format t "~%*** Trying to connect to DARC via port ~a ...~&"
device-name)
;; Missing: Code that connects to the DARC port via USB ...
;; For now, just return NOT CONNECTED ...
:not-connected
)
)
(defobserver status ((self rs232c-port))
(format t "~%*** Status of RS232C port ~a is now ~s.~%"
(device-name self)
(status self))
(when new-value
(if (eq new-value :connected)
(setf (state (first (timers self))) :off)
(setf (state (first (timers self))) :on)
)))
;; HELPER FUNCTIONS
;; Toggles :on to :off and vice versa
(defun on-off-toggle (on-or-off)
(case on-or-off
( :on :off)
( :off :on )
(otherwise :off))) ; Safety ! Turn off in case of unknown value
given
; (= bug in app) ...
;; PSU-RC-APP OBSERVERS
(defobserver mains-status ((self psu-rc-app))
(format t "~%*** Mains-status is now ~s.~%" new-value))
(defobserver lamp-state ((self signal-lamp))
(format t "~%*** Signal lamp ~a is now ~s.~%" (id self) new-value))
(defobserver pressed ((self pushbutton))
(format t "~%*** Pushbutton ~a has been pressed (~s).~%" (id self)
new-value))
(defobserver switched ((self signal-lamp))
(format t "~%*** Lamp ~a has been switched (~s).~%" (id self) new-
value))
;(defobserver pressed ((self pushbutton-with-signal-lamp))
; (setf (switched (fm^ (md-name self)) t)))
;; Get a view / window right after making an instance
;; We only allow one instance to run !
(defmethod initialize-instance :after ((self psu-rc-app) &key)
(when *psu-rc-app*
(error "*** A PSU-APP-RC instance already exists. Only one
allowed."))
(setq *psu-rc-app* self)
(setf (view self) (make-instance 'psu-rc-app-view))
(setf (darc-rs232c-port self) (make-instance 'rs232c-port)))
;; PSU-RC-APP-VIEW - the view/GUI for the PSU Remote Control Application
(defmodel psu-rc-app-view (window)
((selected-oper-pb :cell :ephemeral :accessor selected-oper-pb
:initform (c-in nil) :initarg :selected-oper-pb)
(selected-test-pb :cell :ephemeral :accessor selected-test-pb
:initform (c-in nil) :initarg :selected-test-pb))
(:default-initargs
:id :psu-rc-app-view
:kids (c? (the-kids
(app-menubar)
(control-panel)
(darc-setup-panel)
))))
;(defmethod initialize-instance :after ((self psu-rc-app-view) &key)
; (tk-format '(:configure "title") "wm title . ~a" (slot-value self
'title$)))
(defobserver title$ ((self window))
(tk-format '(:configure "title") "wm title . ~a" (or new-value
"Untitled")))
(defun app-menubar ()
(mk-menubar
:id :psu-rc-menu-bar
:kids (c? (the-kids
(mk-menu-entry-cascade-ex (:label "File")
(mk-menu-entry-command
:label "Quit"
:command "exit"))
(mk-menu-entry-cascade-ex (:label "Operate")
(mk-menu-entry-command
:label "Set Mains Status to :OK"
:command (c? (tk-callback .tkw 'set-mains-ok
(lambda () (setf (mains-status *psu-rc-app*) :ok)))))
(mk-menu-entry-command
:label "Action: Push the OPER MODE button"
:command (c? (tk-callback .tkw 'push-oper-
mode-pb
(lambda ()
(setf (pressed (fm^ :oper-mode-pb)) t))))
)
)
)
)
)
)
(defun darc-setup-panel () ; <<< frgo: HERE
(mk-stack ()
(mk-row ()
(mk-label :text "DARC RS232C Port Device Name:")
(mk-entry :id :darc-port-device-name
:md-value (c-in "")
:background "grey"))
(mk-row ()
(mk-label :text "DARC Connect Status:")
(mk-canvas ;;
:height 40
:width 40
:kids (c? (the-kids (mk-rectangle
:coords '(0 0 40 40)
:tk-fill (c? (if (eq (if (darc-rs232c-port *psu-rc-app*) (status
(darc-rs232c-port *psu-rc-app*))
nil)
:connected)
"green"
"red")))))))
(mk-row ()
(mk-label :text (c? (if (darc-rs232c-port *psu-rc-app*)
(status (darc-rs232c-port *psu-rc-app*))
""))
:relief 'sunken))))
(defun run-psu-rc-app ()
(cells-reset 'tk-user-queue-handler)
(tk-test-class 'psu-rc-app))
More information about the cells-devel
mailing list