~ajk/plant-control

b76f8165477e0c21ed7b7117aba04791a67320cc — Andrew Kay 2 years ago
Initial commit
A  => .gitignore +2 -0
@@ 1,2 @@
*.swp
_TODO.md

A  => genera/.gitignore +3 -0
@@ 1,3 @@
*.lisp.~*~
_push.sh
_pull.sh

A  => genera/plant-control-sysdcl.lisp +4 -0
@@ 1,4 @@
;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: USER; -*-

(defpackage plant-control
  (:use "SCL"))
\ No newline at end of file

A  => genera/plant-control.lisp +230 -0
@@ 1,230 @@
;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: PLANT-CONTROL; -*-

(defparameter *redis-host* "SCARAB")

(defflavor tag (key x y (value nil)) ()
  (:initable-instance-variables key x y)
  (:settable-instance-variables value))

;; Program

(dw:define-program-framework plant-control
  :pretty-name "Plant Control"
  :top-level (plant-control-top-level)
  :select-key #\a

  :command-definer t
  :command-table (:inherit-from '("colon full command"
                                  "standard arguments"
                                  "input editor compatibility")
                  :kbd-accelerator-p 'nil)

  :state-variables ((tags (list
                            (make-instance 'tag :key "V1" :x 65 :y 210)
                            (make-instance 'tag :key "T1LVL" :x 300 :y 250)
                            (make-instance 'tag :key "T1TEMP" :x 300 :y 300)
                            (make-instance 'tag :key "PUMP1" :x 285 :y 490)
                            (make-instance 'tag :key "V2" :x 245 :y 90)
                            (make-instance 'tag :key "T2LVL" :x 480 :y 130)
                            (make-instance 'tag :key "T2TEMP" :x 480 :y 180)
                            (make-instance 'tag :key "PUMP2" :x 465 :y 370)
                            (make-instance 'tag :key "T3LVL" :x 845 :y 300)
                            (make-instance 'tag :key "T3TEMP" :x 845 :y 350)
                            (make-instance 'tag :key "V3" :x 945 :y 540)))
                    (refresh-time nil)
                    (refresh-source nil)
                    (background-timer-id nil)
                    (background-timer-frequency nil))

  :panes ((title :title
                 :default-character-style '(:eurex :italic :very-large))
          (viewer :display
                  :redisplay-function 'display-viewer
                  :margin-components `((dw:margin-borders)
                                       (dw:margin-label :margin :bottom
                                                        :style (:swiss :italic :normal)
                                                        :string "Plant")))
          (commands :command-menu
                    :menu-level :plant-commands
                    :rows '(("Refresh" "Kill"))
                    :center-p t
                    :equalize-column-widths t)
          (interactor :interactor
                      :end-of-page-mode :scroll
                      :margin-components `((dw:margin-ragged-borders)
                                           (dw:margin-scroll-bar))))
  :terminal-io-pane interactor
  :configurations `((main
                      (:layout (main :column title middle interactor)
                               (middle :row viewer commands))
                      (:sizes
                        (main (title 1 :lines) (interactor 10 :lines) :then (middle :even))
                        (middle (commands 0.20) :then (viewer :even))))))

(defun plant-control-top-level (program)
  (let ((prompt #'si:arrow-prompt))
    (dw:default-command-top-level program :prompt prompt :dispatch-mode :command-preferred)))

;; Commands

(define-plant-control-command (com-refresh :menu-accelerator t :menu-level :plant-commands)
  ()
  (refresh-tag-values self "Manual")
  (send dw:*program-frame* :redisplay-pane 'viewer t))

(define-plant-control-command (com-kill :menu-accelerator t :menu-level :plant-commands)
  ()
  (send dw:*program-frame* :kill))

(define-plant-control-command (com-start-background-refresh)
  ((frequency '((integer 1 *))
              :prompt "Frequency (seconds)"
              :default 1))
  (start-background-refresh self frequency))

(define-plant-control-command (com-stop-background-refresh)
  ()
  (stop-background-refresh self))

;; Data

(defmethod (refresh-tag-values plant-control) (source)
  (let* ((keys (mapcar (lambda (tag) (clos:slot-value tag 'key)) tags))
         (values (redis-mget *redis-host* keys)))
    (mapcar (lambda (tag value) (send tag :set-value value)) tags values))
  (setf refresh-time (get-universal-time))
  (setf refresh-source source))

(defmethod (start-background-refresh plant-control) (frequency)
  (let ((plant-control self)
        (program-frame dw:*program-frame*))
    (unless background-timer-id
      (setf background-timer-frequency frequency)
      (setf background-timer-id (si:add-timer-queue-entry (list :relative frequency)
                                                          (list :forever frequency)
                                                          "Plant Control Background"
                                                          'background-refresh
                                                          plant-control
                                                          program-frame)))))

(defmethod (stop-background-refresh plant-control) ()
  (when background-timer-id
    (si:remove-timer-queue-entry background-timer-id)
    (setf background-timer-id nil)))

(defun background-refresh (plant-control program-frame)
  (refresh-tag-values plant-control "Auto")
  (send program-frame :redisplay-pane 'viewer t))

;; Drawing

(defmethod (display-viewer plant-control) (stream)
  (dw:with-own-coordinates (stream :erase-window t)
    (draw-plant self stream)
    (dolist (tag tags)
      (draw-tag tag stream))
    (draw-status self stream)))

(defun format-status (time source)
  (if time
    (multiple-value-bind (seconds minutes hours nil nil nil nil nil nil)
                         (decode-universal-time time)
      (format nil "Last updated ~2,'0d:~2,'0d:~2,'0d (~a)" hours minutes seconds source))
    "Not updated"))

(defmethod (draw-status plant-control) (stream)
  (multiple-value-bind (nil nil width nil)
    (send stream :visible-cursorpos-limits)
    (let ((status (format-status refresh-time refresh-source)))
      (graphics:draw-string status (- width 5) 5
                            :attachment-x :right :attachment-y :top
                            :stream stream))))

(defmethod (draw-plant plant-control) (stream)
  (graphics:draw-line 20 160 60 160 :thickness 3 :stream stream)

  ;; VALVE1
  (draw-valve 60 160 stream)

  (graphics:draw-line 140 160 220 160 :thickness 3 :stream stream)
  (graphics:draw-line 220 160 220 200 :thickness 3 :stream stream)

  ;; TANK1
  (draw-small-tank 180 215 stream)

  (graphics:draw-line 240 360 240 420 :thickness 3 :stream stream)
  (graphics:draw-line 240 420 300 420 :thickness 3 :stream stream)

  ;; PUMP1
  (draw-pump 300 420 stream)

  (graphics:draw-line 200 40 240 40 :thickness 3 :stream stream)

  (graphics:draw-line 340 420 660 420 :thickness 3 :stream stream)
  (graphics:draw-line 660 420 660 210 :thickness 3 :stream stream)
  (graphics:draw-line 660 210 800 210 :thickness 3 :stream stream)
  (graphics:draw-line 800 210 800 250 :thickness 3 :stream stream)  

  ;; VALVE2
  (draw-valve 240 40 stream)

  (graphics:draw-line 320 40 400 40 :thickness 3 :stream stream)
  (graphics:draw-line 400 40 400 80 :thickness 3 :stream stream)

  ;; TANK2
  (draw-small-tank 360 95 stream)

  (graphics:draw-line 420 240 420 300 :thickness 3 :stream stream)
  (graphics:draw-line 420 300 480 300 :thickness 3 :stream stream)

  ;; PUMP2
  (draw-pump 480 300 stream)

  (graphics:draw-line 520 300 640 300 :thickness 3 :stream stream)
  (graphics:draw-line 640 300 640 190 :thickness 3 :stream stream)
  (graphics:draw-line 640 190 820 190 :thickness 3 :stream stream)
  (graphics:draw-line 820 190 820 250 :thickness 3 :stream stream)

  ;; TANK3
  (graphics:draw-line 720 245 760 250 :thickness 5 :stream stream)
  (graphics:draw-line 760 250 760 430 :thickness 5 :stream stream)
  (graphics:draw-line 760 430 860 450 :thickness 5 :stream stream)
  (graphics:draw-line 860 450 900 450 :thickness 5 :stream stream)
  (graphics:draw-line 900 450 1000 430 :thickness 5 :stream stream)
  (graphics:draw-line 1000 430 1000 250 :thickness 5 :stream stream)
  (graphics:draw-line 1000 250 1040 245 :thickness 5 :stream stream)

  (graphics:draw-line 880 450 880 490 :thickness 3 :stream stream)
  (graphics:draw-line 880 490 940 490 :thickness 3 :stream stream)

  ;; VALVE3
  (draw-valve 940 490 stream)

  (graphics:draw-line 1020 490 1060 490 :thickness 3 :stream stream))

(defmethod (draw-tag tag) (stream)
  (graphics:draw-string key x y :stream stream)
  (graphics:draw-rectangle (- x 5) (- y 18) (+ x 75) (+ y 25)
                           :filled nil
                           :dashed t :dash-pattern '(2 2)
                           :stream stream)
  (when value
    (graphics:draw-string value x (+ y 20) :stream stream)))

(defun draw-valve (x y stream)
  (graphics:draw-line x (- y 20) (+ x 80) (+ y 20) :thickness 2 :stream stream)
  (graphics:draw-line (+ x 80) (+ y 20) (+ x 80) (- y 20) :thickness 2 :stream stream)
  (graphics:draw-line (+ x 80) (- y 20) x (+ y 20) :thickness 2 :stream stream)
  (graphics:draw-line x (+ y 20) x (- y 20) :thickness 2 :stream stream))

(defun draw-pump (x y stream)
  (graphics:draw-circle (+ x 20) y 20 :inner-radius 18 :stream stream)
  (graphics:draw-rectangle x (+ y 20) (+ x 40) (+ y 40) :filled nil :thickness 2 :stream stream))

(defun draw-small-tank (x y stream)
  (graphics:draw-line x y (+ x 20) (+ y 5) :thickness 5 :stream stream)
  (graphics:draw-line (+ x 20) (+ y 5) (+ x 20) (+ y 125) :thickness 5 :stream stream)
  (graphics:draw-line (+ x 20) (+ y 125) (+ x 60) (+ y 145) :thickness 5 :stream stream)
  (graphics:draw-line (+ x 60) (+ y 145) (+ x 100) (+ y 125) :thickness 5 :stream stream)
  (graphics:draw-line (+ x 100) (+ y 125) (+ x 100) (+ y 5) :thickness 5 :stream stream)
  (graphics:draw-line (+ x 100) (+ y 5) (+ x 120) y :thickness 5 :stream stream))

A  => genera/redis.lisp +62 -0
@@ 1,62 @@
;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: PLANT-CONTROL; -*-
;;;
;;; NOTES
;;; -----
;;; * This client uses the "inline command" format for requests for simplicity of
;;;   implementation - this should be replaced with the real Redis protocol for
;;;   requests however given only GET and MGET are implemented this is not a problem
;;;   for now.
;;;
;;; * UNIX stream translation is used to ensure that <CR><LF> is not converted into
;;;   a single character as with ASCII translation as this causes the STRING-IN method
;;;   to fail as the length does not match.

(defun parse-response (response)
  (let ((type (char response 0))
        (data (subseq response 1)))
    (case type (#\+ (values :simple-string data))
               (#\- (values :error data))
               (#\: (values :integer data))
               (#\$ (values :bulk-string data))
               (#\* (values :array data))
               (otherwise (error "Unknown type")))))

(defun read-response (stream)
  (let ((response (read-line stream)))
    (multiple-value-bind (type data) (parse-response response)
      (case type (:simple-string data)
                 (:error (error data))
                 (:integer (parse-integer data))
                 (:bulk-string (read-bulk-string stream (parse-integer data)))
                 (:array (read-array stream (parse-integer data)))))))

(defun read-bulk-string (stream length)
  (when (eq -1 length) (return-from read-bulk-string nil))
  (let ((bulk-string (make-array length :element-type 'character)))
    (send stream ':string-in "Unexpected EOF" bulk-string 0 length)
    (read-char stream) (read-char stream)
    bulk-string))

(defun read-array (stream length)
  (when (eq -1 length) (return-from read-array nil))
  (loop repeat length collect (read-response stream)))

;;

(tcp:add-tcp-port-for-protocol :redis 6379)

(net:define-protocol :redis (:redis :byte-stream)
  (:invoke-with-stream-and-close ((stream :translation :unix :character t) request)
    (write-line request stream)
    (send stream ':force-output)
    (read-response stream)))

(defun redis-execute (host request)
  (let ((host (net:parse-host host)))
    (net:invoke-service-on-host :redis host request)))

(defun redis-get (host key)
  (redis-execute host (format nil "GET ~a" key)))

(defun redis-mget (host keys)
  (redis-execute host (format nil "MGET ~{~a~^ ~}" keys)))