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* ,@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* ,@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* ,@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))