path: root/guile/starlet/cue-list.scm

;;
;; starlet/cue-list.scm
;;
;; Copyright © 2020-2022 Thomas White <taw@bitwiz.org.uk>
;;
;; This file is part of Starlet.
;;
;; Starlet is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;
(define-module (starlet cue-list)
  #:use-module (oop goops)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 atomic)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-43)
  #:use-module (starlet fixture)
  #:use-module (starlet state)
  #:use-module (starlet clock)
  #:use-module (starlet utils)
  #:use-module (starlet transition-effect)
  #:use-module (starlet snap-transition)
  #:use-module (starlet crossfade)
  #:export (cue
            cue-part
            cue-list
            qnum
            get-cue-parts
            get-cue-clock
            get-preset-state
            get-cue-part-state
            get-cue-part-transition
            cue-number-to-index
            cue-index-to-number
            current-cue-clock
            read-cue-list-file)
  #:re-export (snap crossfade))


(define-record-type <cue-part>
  (cue-part state transition)
  cue-part?
  (state        get-cue-part-state
                set-cue-part-state!)
  (transition   get-cue-part-transition))


(define-record-type <cue>
  (make-cue number
            preset-state
            track-intensities
            cue-parts
            cue-clock)
  cue?
  (number             get-cue-number)
  (preset-state       get-preset-state
                      set-preset-state!)
  (track-intensities  track-intensities)
  (cue-parts          get-cue-parts)
  (cue-clock          get-cue-clock))


(define (qnum a)
  (/ (inexact->exact (* a 1000)) 1000))


(define (cue-index-to-number cue-list cue-index)
  (get-cue-number (vector-ref cue-list cue-index)))


(define (cue-number-to-index cue-list cue-number)
  (vector-index (lambda (a)
                  (eqv? (get-cue-number a)
                        cue-number))
                cue-list))


(define (fix-attr-eq fa1 fa2)
  (and (eq? (car fa1) (car fa2))
       (eq? (cdr fa1) (cdr fa2))))


(define (fix-attrs-in-state state)
  (state-map (lambda (fix attr val) (cons fix attr))
             state))


(define (add-fix-attrs-to-list state old-list)
  (lset-union fix-attr-eq
              old-list
              (fix-attrs-in-state state)))


(define (cue-proc number . args)
  (receive
    (states transition-effects cue-parts rest)
    (categorize args lighting-state? transition-effect? cue-part?)
    (let-keywords
      rest
      #f  ;; allow-other-keys?
      ((track-intensities #f))

      (when (> (length states) 1)
        (error "A cue can only contain one state"))

      (when (> (length transition-effects) 1)
        (error "A cue can only contain one transition effect"))

      (let ((the-cue (make-cue (qnum number)
                               #f   ;; preset state, to be filled later
                               track-intensities
                               (cons
                                 (cue-part (car states)
                                           (car transition-effects))
                                 cue-parts)
                               (current-cue-clock))))

        the-cue))))


(define current-cue-clock (make-parameter #f))

(define-syntax cue
  (syntax-rules ()
    ((_ body ...)
     (parameterize ((current-cue-clock (make-clock #:stopped #t)))
       (cue-proc body ...)))))


(define (track-all-cues! the-cue-list)
  (vector-fold
    (lambda (idx prev-state the-cue)
      (let ((the-tracked-state (lighting-state
                                 (apply-state prev-state)
                                 (unless (track-intensities the-cue)
                                   (blackout!))
                                 (apply-state
                                   (get-cue-part-state
                                     (car (get-cue-parts the-cue)))))))
        (set-cue-part-state! (car (get-cue-parts the-cue))
                             the-tracked-state)
        (for-each
          (lambda (part)
            (apply-state (get-cue-part-state part)))
          (cdr (get-cue-parts the-cue)))
        the-tracked-state))
    (make-empty-state)
    the-cue-list))


(define (dark? a)
  (or (eq? a 'no-value)
      (and (number? a)
           (< a 1))))


(define (fixture-dark-in-cue? fix the-cue)
  (every
    (lambda (part)
      (dark? (state-find fix 'intensity (get-cue-part-state part))))
    (get-cue-parts the-cue)))


(define-syntax for-each-cue-part
  (syntax-rules ()
    ((_ the-cue (part) body ...)
     (for-each
       (lambda (part)
         body ...)
       (get-cue-parts the-cue)))))


(define-syntax for-every-attr-in-cue
  (syntax-rules ()
    ((_ the-cue (fix attr val) body ...)
     (for-each-cue-part
       the-cue (part)
       (state-for-each
         (lambda (fix attr val)
           body ...)
         (get-cue-part-state part))))))


(define (preset-all-cues! the-cue-list)
  (let loop ((idx 0))
    (let ((the-cue (vector-ref the-cue-list idx))
          (next-cue (vector-ref the-cue-list (1+ idx)))
          (preset-state (make-empty-state)))
      (for-every-attr-in-cue
        next-cue (fix attr val)
        (unless (intensity? attr)
          (when (fixture-dark-in-cue? fix the-cue)
            (set-in-state! preset-state fix attr val))))
      (set-preset-state! the-cue preset-state))
    (if (< (+ 2 idx) (vector-length the-cue-list))
      (loop (1+ idx))
      (set-preset-state!
        (vector-ref the-cue-list (1+ idx))
        (make-empty-state)))))


(define-syntax cue-list
  (syntax-rules ()
    ((_ body ...)
     (let ((the-cue-list (vector (cue 0
                                      (make-empty-state)
                                      (snap))
                                 body ...)))
       (track-all-cues! the-cue-list)
       (preset-all-cues! the-cue-list)
       the-cue-list))))


(define (read-cue-list-file filename)
  (call-with-input-file
    filename
    (lambda (port)
      (eval (read port) (interaction-environment)))))