diff options
49 files changed, 4348 insertions, 2397 deletions
diff --git a/INSTALL.md b/INSTALL.md new file mode 100644 index 0000000..326fd36 --- /dev/null +++ b/INSTALL.md @@ -0,0 +1,54 @@ +Getting started with Starlet +============================ + +Set up OLA +---------- +First, install and set up [OLA](https://openlighting.org) for your lighting +environment. Start olad if it's not already running: `olad -l 3` (in a separate +terminal). Patch all the output interfaces for your system (see the OLA +documentation for details). + +Use the web interface (http://127.0.0.1:9090/ola.html) to check that you can +control lights properly. + + +Set up Guile +------------ +Install [Guile](https://www.gnu.org/software/guile/), if it's not already +present. Version 3 is required. You will need to install the development +files (`guile-devel` or similar) as well. + +There may be multiple parallel installations of Guile on your system, so make +sure you know the command for launching version 3. On Fedora, the command is +`guile3.0`. + + +Compile Starlet code +-------------------- +Most of Starlet is written in pure Scheme, but there is a small interface +library written in C++ as well as some GUI programs written in C. Compile and +install them as follows: + +``` +$ meson build +$ ninja -C build +$ sudo ninja -C build install +``` + + +Starting up +----------- + +Run `guile`, giving it the path of the Starlet scheme code. From the top-level +Starlet folder: + +``` +$ guile -L guile --listen=/home/myself/guile.socket +``` + +`/home/myself/guile.socket` will be the name of the Unix domain socket to which +the GUI utilities. You can also connect an interactive coding system such as +[Conjure](https://conjure.fun/) or [Geiser](http://www.nongnu.org/geiser/). + +Continue with [patching fixtures](docs/patching.rst). + @@ -3,147 +3,205 @@ Starlet: Stage lighting control in Lisp Starlet is an experimental Lisp-based domain-specific language (DSL) for theatrical lighting control. It's based on -[Guile](https://www.gnu.org/software/guile/) and sends its DMX output via -[OLA](https://openlighting.org) to almost any type of lighting control -interface - DMX, sACN, Art-Net etc. Starlet also undertands MIDI, enabling you -to control lights and cues with physical faders, knobs and buttons. +[Guile](https://www.gnu.org/software/guile/) and uses the +[Open Lighting Architecture](https://openlighting.org) to connect with almost +any type of lighting control interface - USB DMX dongles, sACN, Art-Net etc. +Starlet also understands [Open Sound Control](http://opensoundcontrol.org/), +enabling you to control lights and cues with physical faders, knobs and +buttons. + +Rather than adding "scripting" as an afterthought, Starlet puts the full power +of the programming language in the spotlight, allowing you to *program* your +lights. + +Starlet is explicitly designed for *theatrical* lighting control, with cue +lists, playbacks and multi-part cues being the centre of attention. Automatic +pre-setting of attributes ("auto move while dark") is the default. + + +Video demonstration +------------------- Click for a video demonstration: -[](https://vimeo.com/520547229) +[](https://vimeo.com/520547229) -With Starlet, a cue list looks like this: + +Getting started +--------------- + +Read [INSTALL.md](INSTALL.md) for basic setup instructions. + + +Quick tour +---------- + +Lighting fixtures are referred to by names, rather than numbers: ``` -(define my-cue-list - (cue-list - - (cue 1 - (lighting-state (at dim1 '100)) - (at mh1 'pan 25)) - #:fade-up 3 - #:fade-down 5) - - (cue 2 - (lighting-state (at dim1 '50) - (at dim2 '100) - (at mh1 'pan 50)) - #:fade-up 3 - #:fade-down 1 - #:down-delay 3) - - (cue 3 - (lighting-state #f) ; blackout - #:fade-down 2 -``` +;; Patch some fixtures +(patch-fixture! washL <generic-dimmer> 18)) +(patch-fixture! washM <generic-dimmer> 19)) +(patch-fixture! washR <generic-dimmer> 20)) +(patch-fixture! footlights <generic-dimmer> 23)) +(patch-fixture! moverL <robe-dl7s-mode1> 1 #:universe 4)) +(patch-fixture! moverR <robe-dl7s-mode1> 101 #:universe 4)) -Creating a playback object and running a cue list looks like this: +;; Turn the footlights on at full intensity +(at footlights 100) +;; Turn on both moving lights and set colour +(at moverL moverR 60) +(at moverL moverR colour (rgb 45 10 0)) ``` -(define pb (make-playback #:cue-list my-cue-list)) -(cut-to-cue-number! pb 1) -(go! pb) -(go! pb) -(go! pb) ; and so on +The fixture names are normal Scheme variables. You can do usual things such +as creating lists: + +``` +(define front-wash (list washL washM washR)) +(at front-wash 100) ``` -Lighting states can be prepared separately and assigned to variables: +A lighting state is a collection of attribute values, and can be associated +with a variable name: ``` -(define spooky-dungeon +(define home-state (lighting-state - (at dimmer1 20) - (at dimmer2 20) - (at moving-light 70) - (at moving-light 'red 100) - (at moving-light 'green 10) - (at moving-light 'blue 12))) + (at footlights 100) + (at front-wash 100) + (at moverL moverR 100) + (at moverL moverR tilt 45) + (at moverL pan -15) + (at moverR pan 15))) ``` -You can use pre-prepared states in cues, even if some minor modifications are -needed. This makes it really easy to understand the contents of a cue without -having to interpret a screenful of numbers: +A cue is formed by wrapping a lighting state inside a *transition effect*, +such as a crossfade or snap (zero-time crossfade). A cue list is simply a list +of cues: ``` -(cue 57 - (lighting-state (apply-state spooky-dungeon) - (at follow-spot 100)) - #:fade-up 3 - #:fade-down 3) +(cue-list + + (cue 0.5 + ;; Tab warmers + (snap + (lighting-state + (at washL washR 30) + (at washM 40)))) + + (cue 0.8 + ;; 6-second fade to blackout + (crossfade 6 blackout)) + + (cue 1 + ;; Act 1, Scene 1 + (crossfade 3 + (lighting-state + (at front-wash 80) + (at moverL colour (cmy 25 0 0))) + (at moverL 25))) + + (cue 2 + (crossfade 3 4 ;; Separate up/down fade times + (lighting-state + (at washM 100)))) + + (cue 2.5 + (crossfade 2 + (lighting-state + (apply-state home-state) + (at moverR 100))))) ``` -Multi-part cues are supported. Simply specify the fade parameters and which -fixtures should be in the part: +To 'execute' a cue list, load it into a *playback* object: ``` -(cue 64 - (lighting-state (apply-state indoor-act1-general) - #:fade-up 3 - #:fade-down 3 - - (cue-part (dim3 - dim4 - dim8 - (list moving-light 'pan 'tilt)) - #:down-time 2 - #:down-delay 1)) +(define pb (make-playback #:cue-list my-cue-list)) +(cut-to-cue-number! pb 1) +(go! pb) ``` +By giving names to lighting states, cue lists can be made very concise. The +following example is from a real show: + +``` + (cue 6 (snap blue-state)) + (cue 7 (snap office-state)) + (cue 8 (snap blue-state)) + (cue 9 (snap office-state)) + (cue 10 (snap blue-state)) + (cue 11 (snap office-state)) + (cue 12 (crossfade 2 blackout)) + (cue 13 (snap office-state)) +``` -Everything from a simple dimmers to wacky multi-parameter fixtures are -supported. New fixture classes can be defined using some simple Scheme code. -Patching fixtures looks like this: +Since lighting states are first-class objects, you can even do calculations +with them. In this example (from another real show), the lighting sneaks +progressively darker in a series of slow fades at dramatically appropriate +points: ``` -(patch-fixture! dimmer1 <generic-dimmer> 1)) -(patch-fixture! dimmer2 <generic-dimmer> 3)) -(patch-fixture! balcony-backlight1 <generic-dimmer> 18)) -(patch-fixture! balcony-backlight2 <generic-dimmer> 19)) -(patch-fixture! footlights <generic-dimmer> 23)) -;; Universe numbering starts at zero, matching OLA -(patch-fixture! moving-light <robe-dl7s-mode1> 1 #:universe 4)) + (cue 2 (crossfade 1 evening-state)) + (cue 3 (crossfade 15 (part-way-between evening-state night-state 0.2))) + (cue 4 (crossfade 15 (part-way-between evening-state night-state 0.4))) + (cue 5 (crossfade 15 (part-way-between evening-state night-state 0.6))) + (cue 6 (crossfade 15 (part-way-between evening-state night-state 0.8))) + (cue 7 (crossfade 15 night-state)) ``` -Note that the names of the fixtures are just normal Scheme variables. They can -be anything you like, and you're encouraged to make the names more descriptive -than logical channel numbers, where appropriate. +The _structure_ of the cue list is thus separated from the _design_ of the +lighting states. The structure can often be decided and programmed weeks in +advance of the show, leaving you to concentrate on the designing the states +during the technical rehearsal. -Getting started ---------------- +Documentation index +------------------- + +* [Patching fixtures](docs/patching.rst) +* [Basic attribute control and building states](docs/basic-control.rst) +* [Cue lists and playbacks](docs/cue-list.rst) +* [The fixture display tool](docs/fixture-display.rst) +* [Physical controls](docs/physical-control.rst) +* [Defining a new type of fixture](docs/new-fixture.rst) + -1. Install and set up [OLA](https://openlighting.org) for your lighting - environment. -2. Install [Guile](https://www.gnu.org/software/guile/), if it's not already - there. Version 3 is required. -3. Install Starlet: - `meson build`, `ninja -C build` and `sudo ninja -C build install` -4. Start olad if it's not already running: `olad -l 3` (in a separate - terminal). -5. Run `guile`. -6. Once in the Guile REPL, import some Starlet modules: - `(use-modules (starlet scanout) (starlet state) (starlet fixture-library - generic dimmer))` -7. Patch a fixture: - `(patch-fixture! mydimmer <generic-dimmer> 1 #:universe 2)` - Replace 1 and 2 with the DMX address and universe (respectively) of a real - dimmer. -8. Turn the dimmer on with `(at mydimmer 100)` -9. Look in the _examples_ and _docs_ folders for more advanced ideas. +(Non-)warranty +-------------- + +Starlet is an experiment in progress, and there are no guarantees of any kind +of stability (non-crashiness, consistency of language etc). Don't rely on +syntax and interfaces staying the same, i.e. don't "git pull" right before a +show! Nevertheless, Starlet is reliable enough for adventurous types to +consider using it for real shows. Here it is running a show in front of a live +(paying!) audience in June 2023: + + + + +About the name +-------------- + +* Star-let: The little star of your show, of course. +* Let-star (let*): the sequentially evaluated form of the + [local binding syntax](https://www.scheme.com/tspl4/binding.html#./binding:h4) + in Scheme. +* [CCT Starlette](http://www.cctlighting.co.uk/125/Theatre_spotlights/Starlette_Luminaire_Range.html): + a range of theatrical lighting fixtures. Related projects ---------------- -There are many stage lighting software projects, but most of them seem to -concentrate on "disco style" effects and chases whereas Starlet is aimed more -towards theatre shows. Here are some that I found especially interesting: +Here are some related projects that I found especially interesting. +Amazingly, Starlet is not the only project to be found in the almost absurdly +specialised category of "Lisp-based stage lighting systems"! - -* [Fivetwelve-CSS](https://github.com/beyondscreen/fivetwelve-css) DMX lighting - control using CSS. [Watch this video](https://www.youtube.com/watch?v=ani_MOZt5_c) * [Afterglow](https://github.com/Deep-Symmetry/afterglow) Clojure live coding environment using OLA +* [Fivetwelve-CSS](https://github.com/beyondscreen/fivetwelve-css) DMX lighting + control using CSS. [Watch this video](https://www.youtube.com/watch?v=ani_MOZt5_c) * [QLC+](https://qlcplus.org/) the most popular open-source lighting control program diff --git a/docs/basic-control.rst b/docs/basic-control.rst new file mode 100644 index 0000000..6584d77 --- /dev/null +++ b/docs/basic-control.rst @@ -0,0 +1,144 @@ +=========================================== +Basic attribute control and building states +=========================================== + +Once your fixtures are patched (see `<patching.rst>`_), you can set attributes +using ``at``. For example, to set the intensity of ``my-dimmer`` to 100%:: + + (at my-dimmer intensity 100) + +If you leave out the attribute name, then ``intensity`` will be assumed:: + + (at my-dimmer 100) + +The available parameters are determined by the fixture definition (see +`<new-fixture.rst>`_). For example:: + + (at my-moving-light pan 32) + (at my-moving-light tilt 70) + (at my-moving-light zoom 60) + +Not all fixtures accept a single number. For example, ``colour`` takes a +colour object, which can be constructed using ``rgb`` or ``cmy``. Starlet (or +rather, the fixture definition code) is responsible for converting the colour +to the native representation used by the fixture:: + + (at my-moving-light colour (rgb 80 23 25)) + +You can set attributes for multiple fixtures at once:: + + (at spotCS spotSR spotSL 90) + +Or you can set attributes for a list of fixtures:: + + (define all-spots (list spotSL spotCS spotSR)) + (at all-spots 90) + +You can mix individual fixtures and lists of fixtures. However, you can only +set one attribute (to one value) at a time. + + +The selection +============= + +When setting many attributes for one fixture, you can avoid typing the +fixture name each time by using the selection. To select a fixture, call +``sel`` with the fixture(s) to select:: + + (sel my-dimmer) + (sel all-spots my-moving-light) + +If the fixture name is left out from subsequent calls to ``at``, they will +apply to the currently selected fixture(s). To clear the selection, use +``(sel #f)`` or simply ``(sel)``:: + + (sel my-moving-light) + (at 100) + (at colour (rgb 80 23 25)) + (at tilt 70) + (at pan 32) + (sel #f) + +The fixture display window (see `<fixture-display.rst>`_) will highlight the +selection, and physical control devices (see `<physical-control.rst>`_) will +affect the selected fixture(s). + +To see the contents of the selection, use ``(get-selection)``. + + +State objects +============= + +Attribute values must be stored within a state object. When you set an +attribute from the Guile REPL, the values will be stored in the programmer +state. You can examine the contents using ``state-source``, which returns +the Scheme code corresponding to the state's contents:: + + scheme@(guile-user)> (state-source programmer-state) + $6 = (lighting-state (at ledLL colour (cmy 77.0 100.0 100.0)) (at ledRR colour (cmy 77.0 100.0 100.0)) (at washR intensity 85) (at washL intensity 85) (at ledLL intensity 40) (at ledRR intensity 40) (at washM intensity 85)) + +You can also use ``print-state``, which just pretty-prints the output of +``state-source``. To reduce typing, you can use ``ps`` as a synonym for +``programmer-state``:: + + scheme@(guile-user)> (print-state ps) + (lighting-state + (at ledLL colour (cmy 77.0 100.0 100.0)) + (at ledRR colour (cmy 77.0 100.0 100.0)) + (at washR intensity 85) + (at washL intensity 85) + (at ledLL intensity 40) + (at ledRR intensity 40) + (at washM intensity 85)) + +You can construct new states by wrapping your ``at`` forms inside +``lighting-state``. These state objects can be used inside cue lists +(see `<cue-list.rst>`_), bound to variables etc:: + + (define my-state + (lighting-state + (at spotSR spotSL 50) + (at spotCS 100))) + +The programmer state has priority over everything else (e.g. cue list +playbacks). To avoid surprises, you should make sure that it's empty before +trying to run a show. The ``clear-state!`` procedure empties a state object +of its contents, without deleting the state itself:: + + (clear-state! ps) + +There are some utility routines for handling states: + +* ``(state-empty? my-state)`` returns ``#t`` if ``my-state`` is empty, + otherwise ``#f``. +* ``(remove-fixture-from-state! my-state spotCS)`` removes all attributes for + ``spotCS`` from ``my-state``. +* ``(remove-fixtures-from-state! my-state (list spotCS spotSL))`` is the same, + but removes a list of fixtures from the state. +* ``(remove-selection-from-programmer!)`` removes from the programmer any + attributes referring to fixtures which are currently selected. It is + defined as follows:: + + (define (remove-selection-from-programmer!) + (remove-fixtures-from-state! + programmer-state + (get-selection))) + + +Effects +======= + +Attribute values aren't restricted to constants. You can also provide a +function, for example:: + + (let ((clock (make-clock))) + (at washM + (lambda () + (* 50 + (+ 1 (sin (* 2 (elapsed-time clock)))))))) + +That's obviously quite complicated, so use the functions in module +``(starlet effects)`` instead. For a sine wave once every 2 seconds (0.5 Hz) +ranging between zero and 100%:: + + (at washM (sinewave 0.5 0 100)) diff --git a/docs/cue-list.rst b/docs/cue-list.rst new file mode 100644 index 0000000..b6bda08 --- /dev/null +++ b/docs/cue-list.rst @@ -0,0 +1,276 @@ +======================= +Cue lists and playbacks +======================= + +Anatomy of a cue +================ + +Here is cue 4.3 representing a 4 second crossfade to a dim lighting wash:: + + (cue 4.3 ;; Cue number 4.3 + (crossfade 4 ;; Cross-fade in 4 seconds + (lighting-state ;; To a lighting state... + (at washL washR 30) ;; ... consisting of 'washL' and 'washR' at 30% intensity + (at washM 40)))) ;; ... and 'washM' at 40% intensity. + +Other types of transition are possible. For example, the simplest transition +of all is a "snap" (a hard, immediate change):: + + (cue 4.3 + (snap + (lighting-state + (at washL washR 30) + (at washM 40)) + +The simplest transition effect is ``snap``, which produces a hard zero-time +transition to the cue. The usual one is ``crossfade``, which produces a smooth +fade in the time you specify (in seconds). It gives you a lot of control, for +example, to fade intensities up in 4 seconds but down in 2 seconds:: + + (crossfade 4 2 state) + +To delay the up fade part by 2 seconds relative to everything else:: + + (crossfade 4 #:up-delay 2 state) + +To delay the down fade part, use ``#:down-delay``. To control the fade times +for non-intensity parameters, use ``#:attr-time`` and ``#:attr-delay``. +Putting it all together for a complicated crossfade:: + + (crossfade 3 4 + #:up-delay 2 + #:attr-time 1 + #:attr-delay 1.5 + (lighting-state ...)) + +You can write your own transition effects, if you want some other kind of +transition. Documentation pending, but look at snap-transition.scm and +crossfade.scm for some examples. + +The lighting state does not have to feature a literal ``lighting-state`` form. +Let's say you defined a state somewhere else:: + + (define my-state + (lighting-state + (at spotSR spotSL 50) + (at spotCS 100))) + +You can refer to that state in a cue like this:: + + (cue 3 + (crossfade 3 5 my-state)) + +You can also layer changes on top of the state, by using ``apply-state`` (which +does exactly what its name suggests):: + + (cue 3 + (crossfade 3 5 + (lighting-state + (apply-state my-state) + (at upstage-spot)))) + +You can even make those changes conditional:: + + (define spot-needed #f) + + (cue 3 + (crossfade 3 5 + (lighting-state + (apply-state my-state) + (when spot-needed + (at upstage-spot 100))))) + + +Multi-part cues +=============== + +To make certain fixtures fade differently during the same cue, simply add a +separate transition for each part. Here's an example (from a real show):: + + (cue 3 + + (crossfade 6 #:up-delay 14 + (lighting-state + (at highsideL intensity 100.0) + (at highsideR intensity 100.0) + (at front-leds colour (cmy 0 93 80)) + (at splitL splitR 70) + (at washL washR 100) + (at washM 50))) + + (crossfade 3 + (lighting-state + (at portrait-spot 100))) + + (crossfade 3 #:up-delay 16 + (lighting-state + (at front-leds 100)))) + +In this example, the ``portrait-spot`` fades up first, in 3 seconds. The main +part of the scene fades up more slowly, in 6 seconds after a delay of 14 +seconds. The ``front-leds`` (a group containing all of the front-light LED +fixtures) fades up a further 2 seconds after that. Note that the cue parts +don't need to appear in chronological order. However, the first cue part is +"special", because it's the one *into* which the other parameters will track +(see below). + + +Cue lists +========== + +A cue list is simply a list of cues. For example:: + + (cue-list + + (cue 0.5 + ;; Tab warmers + (snap + (lighting-state + (at washL washR 30) + (at washM 40)))) + + (cue 0.8 + (crossfade 6 blackout)) + + (cue 1 + ;; Act 1, Scene 1 + (crossfade 3 + (lighting-state + (at front-wash 80) + (at moverL colour (cmy 21 0 0)) + (at moverL 25)))) + + (cue 2 + (crossfade 3 4 ;; Separate up/down fade times + (lighting-state + (at washM 100)))) + + (cue 2.5 + (crossfade 2 + (lighting-state + (apply-state home-state) + (at moverR 100))))) + +Just so you know, the cue list is represented internally as a Scheme *vector*, +not a real list. + + +Playback objects +================ + +The cue list doesn't do anything on its own. To actually see the contents on +the stage, it needs to be loaded into a playback. In practice, the best way to +work is to put the cue list in a file on its own and create the playback with +a reference to that file:: + + (define pb + (make-playback + #:cue-list-file "shows/my-show.qlist.scm" + #:recovery-file "recovery.q")) + +The ``#:recovery-file`` is optional but highly recommended, discussed below. + +Once the playback has been created like this, if you change the cue list file +then you can re-load it:: + + scheme@(guile-user)> (reload-cue-list! pb) + $8 = cue-list-reloaded + +If the modifications to the cue list file involved the currently active cue, +the state shown on the stage will *not* be updated until you say so, with:: + + (reassert-current-cue! pb) + +The playback object shows useful information when printed:: + + scheme@(guile-user)> pb + $1 = #<<starlet-playback> state: ready current-cue: 43.0 next-cue: 44.0> + +For completeness, know that you can also create a playback like this:: + + (define my-cue-list + (cue-list + (cue ...))) + + (define pb (make-playback #:cue-list my-cue-list)) + +However, this makes it much harder to make subsequent changes to the cue list. + + +Running cues +============ + +To rapidly jump (with a snap transition) to a cue, use ``cut-to-cue-number!``. +To run a cue using the transition specified in the cue list, use +``run-cue-number!``:: + + (cut-to-cue-number! pb 1) + (run-cue-number! pb 4) + +Calling ``go!`` will run the next cue in the cue list:: + + (go! pb) + +Playbacks also implement the other familiar operations: + +* ``(stop! pb)`` - immediately pause any running cue. The next call to + ``go!`` will continue it. +* ``(cut! pb)`` - run the next cue, using a snap transition regardless of what + the cue specifies. +* ``(back! pb)`` - go backwards one step in the cue list, using a snap + transition. + + +Tracking +======== + +By default, non-intensity parameters will "track" from one cue into the next +cue. That helps to avoid unexpected parameter changes, e.g. a moving light +changing position while it dims. If you run cues *out of order*, the result +will be the same as if you'd run the cues *in order* from the start, to get to +the cue you wanted. If you're lucky enough to have never encountered a system +that works any other way, just know that it works the way you'd expect it to +work in a theatrical system. + +If you additionally want to track *intensities* into a cue, add +``track-intensities`` as the first thing after the cue number:: + + (cue 1 + (crossfade 3 + (lighting-state + (at front-wash 80)))) + + (cue 2 + track-intensities + (crossfade 3 + (lighting-state + (at spotC 100)))) + +In this example, cue 2 will include ``spotC`` at full intensity, **and** +``front-wash`` at 80% intensity. + + +Fixture presetting ("auto move while dark") +=========================================== + +Starlet tries as hard as it can to get non-intensity parameters into the right +state before running a cue. In other words, it makes a big effort to avoid the +audience seeing moving lights actually move. If a fixture's ``intensity`` +parameter is zero after running a cue, Starlet will set all its non-intensity +parameters to the values in the next cue. Of course, if a non-intensity +parameter changes while the intensity is non-zero, the audience will see the +move! + + +The recovery file +================= + +The purpose of the playback recovery file is to make a rapid recovery after a +crash (not that there will be any, of course!). If the file specified by the +``#:recovery-file`` keyword argument to ``make-playback`` exists when the +playback is created, the playback will immediately jump to the cue number in +the file. Whenever you run (or jump to) a cue, the cue number in the file will +be updated. If you don't use a recovery file, the playback will revert to cue +zero on creation and you'll have to use ``cut-to-cue-number!``. That will +create a blackout of a few seconds while you figure out the right cue number to +pick up from where things went wrong. diff --git a/docs/new-fixture.rst b/docs/new-fixture.rst new file mode 100644 index 0000000..dc55601 --- /dev/null +++ b/docs/new-fixture.rst @@ -0,0 +1,162 @@ +=========================== +Defining a new fixture type +=========================== + +To create a new fixture definition ("personality file"), use the +``define-fixture`` macro from ``(starlet fixture)``:: + + (define-fixture fixture-class-name + (fixture-attributes + list of attributes ...) + scanout code ...) + +The ``fixture-class-name`` should be a GOOPS class name (in triangular +brackets) for the fixture class, of the form ``<manufacturer-model-mode>``, +for example ``<robe-dl7s-mode3>`` for a Robe DL7S profile in mode 3. + +Each attribute follows one of the following forms:: + + (attr-continuous intensity '(0 100) 0) + (attr-colour colour white) + (attr-list prism '(#f 3 5) #f) + +In all cases, you need to provide the name of the attribute. The available +attribute names are enumerated in module (starlet attributes) - please add new +names if you need, but use the available names if possible. The last argument +in each ``attr-`` form is always the default value for the attribute. + +For ``attr-continuous``, you need to give the range of possible values. For +``attr-list``, you need to give a list of the possible discrete values. For +``attr-colour``, the value is always a Starlet colour object. + +The list of attributes is followed by the `scanout code`. This code will be +called to convert the attribute values into DMX values. + +Retrieve the current values with calls of the form ``(get-attr intensity)``, +and set DMX values using ``(set-chan8 nn val)``, where ``val`` is the DMX value +(0 to 255) and ``nn`` is the channel number. The channel numbers are indexed +from 1, i.e. ``(set-chan8 1 255)`` will set the fixture's base DMX address to +255. + +There is also ``(set-chan16 nn val)``, which will set a pair of values to a +16-bit value between 0 and 65535. The lower channel address will get the most +significant byte or 'coarse' value. + +Note that you don't need access (nor do you get access) to the fixture +instance itself. The routines ``get-attr``, ``set-chan8`` and ``set-chan16`` +automatically know which fixture is being worked on at the time of the +procedure call. + + +Tips +==== + +The fixture class name should include enough of the fixture's name to +disambiguate it from other products by the same manufacturer. For example +<stairville-octagon-theater-cw-ww> includes ``cw-ww`` to distinguish the +`CW/WW` (cold/warm wash) variant from the `CW/WW/A` (cold/warm/amber wash) +variant, which has a different channel layout. + +Use the standard names (see below) for attributes as far as possible. This +means that, for example, the same knob on a MIDI control surface can control +the same attribute across a range of different fixtures. Note the UK-style +spelling of some of the attributes (e.g. ``colour``). + +In spite of the above paragraph, use the exact manufacturer's spelling for the +fixture name itself. + +Put the fixture definition into a separate Guile module named +``(starlet fixture-library <manufacturer> <fixture name>)``. +If the fixture has multiple modes, create one fixture class for each and put +them all in the same file. + +Use physically meaningful units where possible. For example, attribute +``colour-temperature`` should be in Kelvin, not arbitrary units. This means +that a set of different fixtures types can all be set to the same value. It +also makes it easily possible to substitute one fixture for a different one +without having to re-program the entire show. + +Be prepared to do some work in the scanout code. It's almost never as simple +as a 1:1 translation from the attributes to DMX channels. Even the cheap +5-channel LED cold/warm fixture in the example below includes some maths. + + +Worked example +============== + +Here is an annotated version of the definition for the +`Stairville Octagon Theatre CW/WW <https://www.thomannmusic.com/stairville_octagon_theater_cw_ww_36x1w.htm>`_. +The channels for this fixture are: + + 1. Cold LED intensity (0-255 min-max) + 2. Warm LED intensity (0-255 min-max) + 3. Strobe (0-15 off, 16-255 slow-fast) + 4. Macro (0-15 direct control with channels 1&2, + 16-255 various pre-programmed colour temperatures) + 5. Overall intensity + +The approximate colour temperature range for the fixture is given in the +manual as 2800K to 6400K. Temperatures in between will be achieved by mixing +the cold and warm LEDs such that the sum is always constant. The midpoint +colour temperature (4600K) will therefore correspond to 50% cold and 50% warm +intensity. + +Note that this design choice reduces the absolute maximum intensity possible +from this fixture, which would be achieved when channels 1, 2 and 5 are all at +maximum. However, we gain the fact that the colour temperature and intensity +parameters are orthogonal: changing temperature will not change the intensity, +and vice-versa. Given that Starlet is a *theatrical* lighting control system, +this kind of trade-off is preferable. + +We will totally ignore the pre-programmed colour temperatures in favour of +having direct control over the cold and warm LED values. The manual does not +even say what the pre-programmed temperatures are, so this is no loss at all. + +Unfortunately, the manual doesn't say what frequencies are meant be 'slow' and +'fast' strobe. We'll assume that 'slow' is 1 Hz, and 'fast' is 25 Hz. + +Here is the code:: + + ;; Define a Guile module for the fixture + (define-module (starlet fixture-library stairville octagon-theater-cw-ww) + + #:use-module (starlet fixture) ;; for define-fixture, attr-continuous etc + #:use-module (starlet scanout) ;; for set-chan8, get-attr etc + #:use-module (starlet utils) ;; for percent->dmxval8 etc + #:export (<stairville-octagon-theater-cw-ww>)) + + (define-fixture + + ;; Name of the fixture class + <stairville-octagon-theater-cw-ww> + + ;; List of attributes + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-continuous colour-temperature '(2800 6400) 3200) + (attr-list strobe '(#f #t) #f) + (attr-continuous strobe-frequency '(1 25) 1)) + + ;; Scanout code follows + + ;; Set unused macro channel to zero + (set-chan8 4 0) + + ;; Set strobe channel + (if (get-attr strobe) + (set-chan8 3 (scale-and-clamp-to-range + (get-attr strobe-frequency) + '(1 25) + '(16 255))) + (set-chan8 3 0)) + + ;; Set intensity channel + (set-chan8 5 (percent->dmxval8 (get-attr intensity)))) + + ;; Set values of warm and cold LEDs according to colour temperature + (let ((coltemp (get-attr colour-temperature))) + (set-chan8 1 (scale-and-clamp-to-range coltemp '(2800 6400) '(0 255))) + (set-chan8 2 (scale-and-clamp-to-range coltemp '(2800 6400) '(255 0)))) + +There are, of course, many more examples in ``guile/starlet/fixture-library``. + diff --git a/docs/patching.rst b/docs/patching.rst index aaf25ff..ca3afdd 100644 --- a/docs/patching.rst +++ b/docs/patching.rst @@ -3,19 +3,18 @@ Patching fixtures ================= To make Starlet aware of a lighting fixture (in theatrical parlance, to "patch" -a fixture), use ``patch-fixture!`` from module ``(starlet scanout)``. You will +a fixture), use ``patch-fixture!`` from module ``(starlet engine)``. You will need to import the fixture definition from the fixture library. For example, to patch a simple dimmer with DMX address 32 on universe 4:: (use-modules - (starlet scanout) + (starlet engine) (starlet fixture-library generic dimmer)) (patch-fixture! my-dimmer <generic-dimmer> 32 #:universe 4) Universe numbering starts from zero (consistent with OLA's numbering), and -channel numbering starts from 1 (consistent with every other system on the -planet). +channel numbering starts from 1. After the above, the symbol ``my-dimmer`` will be bound to an object representing the dimmer:: @@ -26,6 +25,16 @@ representing the dimmer:: Intelligent fixtures should go to their home positions immediately after being patched. +Note that you can give a fixture multiple names. For example, if the spotlight +you use for a throne (``throne-spot``) is re-used to light a table:: + + (define table-spot throne-spot) + +This leaves the door open for replacing ``table-spot`` with a separate fixture +later on, if the re-usage doesn't work out as you expected. In that case, +after rigging the new fixture, simply replace the above ``define`` call with a +new call to ``patch-fixture!``. + Lists of fixtures ================= @@ -34,22 +43,22 @@ Starlet fixture objects are just normal `GOOPS <https://www.gnu.org/software/guile/manual/html_node/GOOPS.html>`_ objects. You can do normal Scheme-y things with them, such as making lists of them:: - (define red-backlight (list backlight-red-usl - backlight-red-usr - backlight-red-dsl - backlight-red-dsr)) + (define red-backlight + (list backlight-red-usl + backlight-red-usr + backlight-red-dsl + backlight-red-dsr)) Procedures such as ``at`` work with these lists in the same way that they work on individual fixtures:: (at red-backlight 100) -See the documentation about setting attributes for more information on this -topic. +See `<basic-control.rst>`_ for more information about ``at``. -Multiple fixtures with similar names -==================================== +Patching multiple fixtures at once +================================== At this point, you might be tempted to create a standard file which defines all the fixtures in your venue, naming them ``dimmer1``, ``dimmer2``, ``dimmer3`` @@ -65,49 +74,33 @@ use descriptive names for your fixture objects. When using Starlet, you shouldn't need to constantly look up fixture names (or worse, numbers) in a lighting plan. Instead, give your fixtures names which represent what they do, for example: ``balcony-front-warm``, ``followspot`` or ``throne-spot``. -Note that you can give a fixture multiple names. For example, if the spotlight -you use for a throne (``throne-spot``) is re-used to light a table:: - - (define table-spot throne-spot) -This leaves the door open for replacing ``table-spot`` with a separate fixture -later on, if the re-usage doesn't work out as you expected. In that case, -simply replace the above ``define`` call with a new call to ``patch-fixture!``. - - -Patching multiple fixtures at once -================================== - -Despite the above, there will probably be times when you have a large number of -fixtures that should be treated to a greater extent as one entity. For this -situation, use ``patch-many!``, which patches a series of fixtures of the same -type. For example, to create eight dimmers with DMX addresses numbered 2, 4, -6... :: - - (patch-many! foh-warm <generic-dimmer> '(2 4 6 8 10 12 14 16)) - -Symbol ``foh-warm`` will be bound to a list containing the fixture objects:: +What you *can* do, however, is to create a list of fixtures all at once. The +individual fixtures in the list won't have their own names, so this is meant +for situations where you mainly want to control the fixtures as a group. For +example, to create eight dimmers with DMX addresses numbered 2, 4, 6... :: + scheme@(guile-user)> (patch-many! foh-warm <generic-dimmer> '(2 4 6 8 10 12 14 16)) scheme@(guile-user)> foh-warm - $2 = (#<<generic-dimmer> 7f6da7c3dc00> #<<generic-dimmer> 7f6da7c3db80> + $1 = (#<<generic-dimmer> 7f6da7c3dc00> #<<generic-dimmer> 7f6da7c3db80> #<<generic-dimmer> 7f6da7c3db00> #<<generic-dimmer> 7f6da7c3da80> #<<generic-dimmer> 7f6da7c3da40> #<<generic-dimmer> 7f6da7c3d9c0> #<<generic-dimmer> 7f6da7c3d940> #<<generic-dimmer> 7f6da7c3d8c0>) + scheme@(guile-user)> (at foh-warm 85) -Instead of explicitly specifying the list of addresses, you could use ``iota``. -For example, this time putting the dimmers on universe 3:: +To address a fixture individually from the list, you would need to use +``list-ref``. This is a little clumsy, but as mentioned above should be a rare +exception:: - (patch-many! foh-warm <generic-dimmer> (iota 8 2 2) - #:universe 3) + (at (list-ref foh-warm 2) 85) -Hopefully obviously, the fixtures in one ``patch-many!`` call all need to be on -the same DMX universe. +Instead of explicitly specifying the list of addresses in ``patch-many!``, you +can use ``iota`` to generate the list of addresses. The following call has the +same effect as the example above, except this time the dimmers are on universe +3 instead of 0:: -For the rare situation when you need to control a single fixture from the list -separately to the others, create a new binding to an item from the list:: - - (define forestage-warm-patch (list-ref foh-warm 2)) + (patch-many! foh-warm <generic-dimmer> (iota 8 2 2) + #:universe 3) -As before, this leaves an easy way to install a dedicated fixture for the -purpose, should it later become necessary, without having to re-write your -entire lighting program. +Note that the fixtures in one ``patch-many!`` call all need to be on the same +DMX universe. diff --git a/docs/physical-control.rst b/docs/physical-control.rst new file mode 100644 index 0000000..743ed89 --- /dev/null +++ b/docs/physical-control.rst @@ -0,0 +1,101 @@ +================================= +Using physical controls (via OSC) +================================= + +Starlet's OSC implementation uses liblo via Guile-OSC. You can use Guile-OSC +procedures directly for many things. Starlet provides utilities for +higher-level control primitives. + +Start OSC by creating a server thread. This will receive OSC method calls from +other programs. You can customise the port number and protocol (UDP vs TCP) as +you need:: + + (define osc-server (make-osc-server-thread "osc.udp://:7770")) + +You'll also need to create an OSC address object for each external program that +will receive OSC calls from Starlet:: + + (define controller (make-osc-address "osc.udp://localhost:7771")) + +Now, you can call external OSC methods like this:: + + (osc-send controller "/my/controller/led/4/set-colour" 'red) + +You can also create methods of your own, like this example which reloads a cue +list on a button press:: + + (add-osc-method + osc-server + "/controller/buttons/30/press" + "" + (lambda () + (reload-cue-list! pb) + (reassert-current-cue! pb))) + +See the manual for `Guile-OSC <https://github.com/taw10/guile-osc>`_ for more +information about this part. + + +High-level controls +=================== + +The functions described below expect the high-level OSC interface as +implemented in `x1k2-midi-osc-alsa <https://github.com/taw10/x1k2-midi-osc-alsa>`_. +See the manual for more information about the protocol. The sections below +describe how to use them in Starlet. Since they need bi-directional +communication, you have to provide an OSC server and the OSC address for the +controller. + + +Selection buttons +----------------- + +This gives you a button that adds a fixture or group to the selection when +pressed. If the button has LEDs, they will be lit orange when selected, and +red otherwise:: + + (osc-select-button front-wash osc-server controller-addr "/controller/buttons/18") + + +Playback controls +----------------- + +This lets you control a playback object with buttons, which will light up to +show when a cue is running. The buttons are (respectively, in argument order) +go, stop and back:: + + (osc-playback-controls pb osc-server controller "/controller/buttons/102" "/controller/buttons/32" "/controller/buttons/28") + + +States on fader (submasters) +---------------------------- + +You can put an entire state on a fader. Non-intensity parameters will be +asserted only when the fader is up (non-zero). If it's not already there, the +fader will need to be picked up at the bottom of its run:: + + (osc-state-fader osc-server controller "/controller/faders/4" + (lighting-state + (at mhL mhR colour (rgb 40 20 70)) + (at mhL mhR 100) + (at front-wash 100) + (at domeL domeR 100))) + + +Parameter encoders and potentiometers +------------------------------------- + +These give you physical control of an individual parameter in the programmer +state. LEDs will be used to indicate whether any of the currently selected +fixtures have the named parameter. + +The simplest form is an encoder. This increases or decreases the parameter +value when turned. Push and turn to make finer adjustments:: + + (osc-parameter-encoder intensity osc-server controller "/controller/encoders/102") + + +Potentiometers are the same, but include a soft pickup mechanism because the +physical position might not match Starlet's view of the position:: + + (osc-smart-potentiometer color-temperature osc-server controller "/controller/potentiometers/4") diff --git a/screenshot.png b/docs/screenshot.png Binary files differindex 1771fdc..1771fdc 100644 --- a/screenshot.png +++ b/docs/screenshot.png diff --git a/docs/show.jpg b/docs/show.jpg Binary files differnew file mode 100644 index 0000000..f538156 --- /dev/null +++ b/docs/show.jpg diff --git a/examples/demo-show.scm b/examples/demo-show.scm new file mode 100644 index 0000000..0195d56 --- /dev/null +++ b/examples/demo-show.scm @@ -0,0 +1,135 @@ +(use-modules + (starlet fixture) + (starlet state) + (starlet playback) + (starlet engine) + (starlet scanout) + (starlet effects) + (starlet colours) + (starlet clock) + (starlet attributes) + (starlet cue-list) + (starlet attributes) + (starlet selection) + (starlet fixture-library generic dimmer) + (starlet fixture-library stairville z120m) + (starlet fixture-library robe dl7s) + (open-sound-control server-thread) + (open-sound-control client) + (starlet open-sound-control utils)) + + +;; Patch fixtures +(patch-fixture! mhLL <robe-dl7s-mode1> 1) +(patch-fixture! mhL <robe-dl7s-mode1> 52) +(patch-fixture! mhR <robe-dl7s-mode1> 104) +(patch-fixture! mhRR <robe-dl7s-mode1> 156) +(patch-fixture! washL <generic-dimmer> 260) +(patch-fixture! washM <generic-dimmer> 261) +(patch-fixture! washR <generic-dimmer> 262) +(patch-fixture! ledLL <stairville-z120m-6ch> 238) +(patch-fixture! ledL <stairville-z120m-6ch> 232) +(patch-fixture! ledR <stairville-z120m-6ch> 250) +(patch-fixture! ledRR <stairville-z120m-6ch> 244) +(patch-fixture! goboL <generic-dimmer> 263) +(patch-fixture! goboR <generic-dimmer> 264) +(patch-fixture! domeL <generic-dimmer> 265) +(patch-fixture! domeR <generic-dimmer> 266) +(patch-fixture! apronL <generic-dimmer> 267) +(patch-fixture! apronR <generic-dimmer> 268) +(patch-fixture! highsideL <generic-dimmer> 269) +(patch-fixture! highsideR <generic-dimmer> 270) +(patch-fixture! floodL <generic-dimmer> 271) +(patch-fixture! floodR <generic-dimmer> 272) + + +;; Set up some groups +(define front-leds (list ledLL ledL ledR ledRR)) +(define front-wash (list washL washM washR)) + + +;; Make a cue list +(define my-cues + (cue-list + + (cue 1 + (crossfade 3 + (lighting-state + (at washL washM washR 80)))) + + (cue 2 + (crossfade 2 5 + (lighting-state + (at washL washM washR 0) + (at ledL ledR colour (cmy 0 0 24)) + (at ledL ledR 100)))) + + (cue 3 + (snap blackout)) + + (cue 4 + (crossfade 1 + (lighting-state + (at washM 100)))) + + (cue 5 + track-intensities + (crossfade 5 + (lighting-state + (at ledL ledR 30))) + (crossfade 2 #:up-delay 5 + (lighting-state + (at apronL apronR 100)))) + + (cue 6 + (snap + (lighting-state + (at washL washR 20)))))) + + +(define pb + (make-playback + #:cue-list my-cues + #:recovery-file "recovery.q")) + + +;; OSC controls +(define osc-server (make-osc-server-thread "osc.udp://:7770")) +(define x1k2 (make-osc-address "osc.udp://localhost:7771")) + +(send-selection-updates-to (make-osc-address "osc.udp://localhost:7772")) + +(osc-playback-controls pb osc-server x1k2 "/x1k2/buttons/LAYER" "/x1k2/buttons/M" "/x1k2/buttons/I") +(osc-playback-controls pb osc-server x1k2 "/x1k2/buttons/SHIFT" "/x1k2/buttons/P" "/x1k2/buttons/L") + +(osc-send x1k2 "/x1k2/buttons/N/set-led" 'green) +(add-osc-method osc-server "/x1k2/buttons/N/press" "" (lambda () + (reload-cue-list! pb) + (reassert-current-cue! pb))) + +(osc-send x1k2 "/x1k2/buttons/O/set-led" 'green) +(add-osc-method osc-server "/x1k2/buttons/O/press" "" sel) + +(osc-select-button front-leds osc-server x1k2 "/x1k2/buttons/A") +(osc-select-button front-wash osc-server x1k2 "/x1k2/buttons/B") +(osc-select-button mhLL osc-server x1k2 "/x1k2/buttons/E") +(osc-select-button mhL osc-server x1k2 "/x1k2/buttons/F") +(osc-select-button mhR osc-server x1k2 "/x1k2/buttons/G") +(osc-select-button mhRR osc-server x1k2 "/x1k2/buttons/H") + +(osc-parameter-encoder pan osc-server x1k2 "/x1k2/encoders/1") +(osc-parameter-encoder tilt osc-server x1k2 "/x1k2/encoders/2") +(osc-parameter-encoder gobo osc-server x1k2 "/x1k2/encoders/3") +(osc-parameter-encoder intensity osc-server x1k2 "/x1k2/encoders/6") +(osc-cmy-potentiometer colour osc-server x1k2 + "/x1k2/potentiometers/1" + "/x1k2/potentiometers/2" + "/x1k2/potentiometers/3") +(osc-smart-potentiometer color-temperature osc-server x1k2 "/x1k2/potentiometers/4") + +(osc-state-fader osc-server x1k2 "/x1k2/faders/4" + (lighting-state + (at mhL mhR colour (rgb 40 20 70)) + (at mhL mhR 100) + (at front-wash 100) + (at domeL domeR 100))) diff --git a/examples/show.scm b/examples/show.scm index d672572..fa78b2e 100644 --- a/examples/show.scm +++ b/examples/show.scm @@ -52,7 +52,7 @@ ;; Fixtures can be grouped together (define ltruss (list ltruss1 ltruss2 ltruss3 ltruss4 ltruss5 ltruss6)) (define rtruss (list rtruss1 rtruss2 rtruss3 rtruss4 rtruss5 rtruss6)) -(define floor (list floor1 floor2 floor3 floor4 floor5 floor6)) +(define all-floor (list floor1 floor2 floor3 floor4 floor5 floor6)) (define my-state @@ -87,6 +87,9 @@ (list 'focus 'fader 10 '(118 82)))) +(make-sensitivity-knob controller 20) + + (define pb (make-playback #:cue-list-file "examples/show.qlist.scm")) @@ -118,7 +121,7 @@ #:ready-note 69) (select-on-button controller 34 foh #:ready-note 70) -(select-on-button controller 35 floor +(select-on-button controller 35 all-floor #:ready-note 71) diff --git a/guile/starlet/attributes.scm b/guile/starlet/attributes.scm new file mode 100644 index 0000000..e139040 --- /dev/null +++ b/guile/starlet/attributes.scm @@ -0,0 +1,104 @@ +;; +;; starlet/attributes.scm +;; +;; Copyright © 2022-2023 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 attributes) + #:use-module (oop goops) + #:export (<starlet-attribute> + make-attribute + attribute? + intensity? + canonical-name + friendly)) + + +(define-class <starlet-attribute> (<object>) + (canonical-name + #:init-keyword #:name + #:getter canonical-name) + (friendly + #:init-keyword #:friendly + #:getter friendly)) + +(define (make-attribute canonical-name friendly) + (make <starlet-attribute> + #:name canonical-name + #:friendly friendly)) + +(define (attribute? a) + (is-a? a <starlet-attribute>)) + +(define-method (write (attribute <starlet-attribute>) port) + (write + (canonical-name attribute) + port)) + +(define-method (canonical-name whatever) + whatever) + + +(define-syntax define-attribute + (syntax-rules () + ((_ name friendly-name) + (define-public name (make-attribute (quote name) friendly-name))))) + + +;; The standard attribute names +(define-attribute intensity "Intensity (percentage of brightest)") +(define-attribute colour "Colour (colour object)") +(define-attribute colour-temperature "Colour temperature (K)") +(define-attribute strobe "Strobe active (boolean)") +(define-attribute strobe-frequency "Strobe rate (Hz)") +(define-attribute pan "Moving head pan angle (degrees +/- from home)") +(define-attribute tilt "Moving head tilt angle (degrees +/- from home)") +(define-attribute prism "Prism active (boolean)") +(define-attribute prism-rotation-speed "Prism rotation speed (+/- percentage of fastest, clockwise)") +(define-attribute frost "Frost active (percentage of maximum frost)") +(define-attribute hotspot "Hot spot (percentage of maximum peakiness)") +(define-attribute iris "Iris (percentage of maximum tightness (perhaps completely closed)") +(define-attribute zoom "Zoom (percentage of tightest zoom)") +(define-attribute focus "Focus (percentage of nearest focus)") +(define-attribute barndoor-all-rotation "Rotation of all barndoors together (degrees +/- from home)") +(define-attribute barndoor1 "Barndoor 1 position (percentage of fully in position)") +(define-attribute barndoor2 "Barndoor 2 position (percentage of fully in position)") +(define-attribute barndoor3 "Barndoor 3 position (percentage of fully in position)") +(define-attribute barndoor4 "Barndoor 4 position (percentage of fully in position)") +(define-attribute barndoor1-rotation "Barndoor 1 rotation (degrees +/- from home)") +(define-attribute barndoor2-rotation "Barndoor 2 rotation (degrees +/- from home)") +(define-attribute barndoor3-rotation "Barndoor 3 rotation (degrees +/- from home)") +(define-attribute barndoor4-rotation "Barndoor 4 rotation (degrees +/- from home)") +(define-attribute beamtype "Beam type") +(define-attribute colwheel "Colour wheel selection (#f or gel name)") +(define-attribute gobo "Gobo selection (#f or gobo name)") +(define-attribute gobo-shift "Fine position of gobo (percentage of maximum shift)") +(define-attribute animation-wheel "Animation wheel active (boolean)") +(define-attribute animation-wheel-position "Animation wheel position (-100 to 100, 0=central)") +(define-attribute animation-wheel-speed "Animation wheel rotation speed and direction (+/- percentage of fastest, clockwise)") +(define-attribute rotating-gobo "Rotating gobo selection (#f or gobo name)") +(define-attribute rotating-gobo-speed "Gobo rotation speed (+/- percentage of maximum speed, clockwise)") +(define-attribute white-weirdness "Weirdness of white (percentage of maximum weirdness)") + +;; Duplicate names for convenience... +(define-public color colour) +(define-public color-temperature colour-temperature) + + +(define (intensity? a) + (eq? intensity a)) + diff --git a/guile/starlet/clock.scm b/guile/starlet/clock.scm index 6c11936..2e6e2ff 100644 --- a/guile/starlet/clock.scm +++ b/guile/starlet/clock.scm @@ -26,8 +26,11 @@ stop-clock! start-clock! reverse-clock! + reset-clock! clock-expired? + set-clock-expiration-time! + <starlet-delayed-clock> make-delayed-clock @@ -63,13 +66,15 @@ (stopped #:init-value #f + #:init-keyword #:stopped #:getter clock-stopped? #:setter set-clock-stopped!) (expiration-time #:init-value #f #:init-keyword #:expiration-time - #:getter expiration-time) + #:getter expiration-time + #:setter set-clock-expiration-time!) (reversed #:init-value #f @@ -78,14 +83,19 @@ (define* (make-clock - #:key (expiration-time #f)) + #:key + (expiration-time #f) + (stopped #f)) (make <starlet-clock> - #:expiration-time expiration-time)) + #:expiration-time expiration-time + #:stopped stopped)) (define (clock-expired? clock) - (> (elapsed-time clock) - (expiration-time clock))) + (and + clock + (> (elapsed-time clock) + (expiration-time clock)))) (define-method (elapsed-time (clock <starlet-clock>)) @@ -117,6 +127,13 @@ (set-clock-stopped! clock #f)) +(define-method (reset-clock! (clock <starlet-clock>)) + (set-start-elapsed-time! clock 0) + (set-start-real-time! clock (time-now)) + (set-clock-reversed! clock #f) + (set-clock-stopped! clock #f)) + + ;; Start the clock running, backwards (define-method (reverse-clock! (clock <starlet-clock>)) (set-start-elapsed-time! clock (elapsed-time clock)) diff --git a/guile/starlet/colours.scm b/guile/starlet/colours.scm index c7d1de0..2162322 100644 --- a/guile/starlet/colours.scm +++ b/guile/starlet/colours.scm @@ -23,10 +23,11 @@ #:use-module (ice-9 exceptions) #:export (<colour> colour? - make-colour-cmy - make-colour-rgb + cmy + rgb colour-as-cmy colour-as-rgb + colour-as-rgbw cyan magenta @@ -36,13 +37,7 @@ blue interpolate-colour - white - - <colour-component-id> - colour-component-id? - colour-component-id - get-colour-component - extract-colour-component)) + white)) (define-class <colour> (<object>) @@ -74,29 +69,31 @@ (colour-type col) (colour-value col))) +(define (three-sf n) + (/ (round (* (exact->inexact n) 10)) 10)) (define-method (write (col <colour>) port) (let ((cmy (colour-as-cmy col))) - (format port "(make-colour-cmy ~a ~a ~a)" - (cyan cmy) - (magenta cmy) - (yellow cmy)))) + (format port "(cmy ~a ~a ~a)" + (three-sf (cyan cmy)) + (three-sf (magenta cmy)) + (three-sf (yellow cmy))))) -(define (make-colour-cmy c m y) +(define (cmy c m y) (make <colour> #:type 'cmy #:value (list c m y))) -(define (make-colour-rgb r g b) +(define (rgb r g b) (make <colour> #:type 'rgb #:value (list r g b))) (define white - (make-colour-cmy 0 0 0)) + (cmy 0 0 0)) (define (colour-as-rgb col) @@ -117,6 +114,15 @@ (make-exception-with-irritants (colour-type col)))))))) +(define (colour-as-rgbw col) + (let ((rgb (colour-as-rgb col))) + (let ((w (apply min rgb))) + (list (- (red rgb) w) + (- (green rgb) w) + (- (blue rgb) w) + w)))) + + (define (colour-as-cmy col) (let ((val (colour-value col))) (case (colour-type col) @@ -138,7 +144,7 @@ (define (interpolate-cmy a b frac) (let ((cmy1 (colour-as-cmy a)) (cmy2 (colour-as-cmy b))) - (make-colour-cmy + (cmy (+ (cyan cmy1) (* frac (- (cyan cmy2) (cyan cmy1)))) (+ (magenta cmy1) (* frac (- (magenta cmy2) (magenta cmy1)))) (+ (yellow cmy1) (* frac (- (yellow cmy2) (yellow cmy1))))))) @@ -155,40 +161,3 @@ (make-exception-with-message "Unrecognised colour interpolation type") (make-exception-with-irritants interpolation-type)))))) - - -(define-class <colour-component-id> (<object>) - (component - #:init-form (error "Colour component must be specified") - #:init-keyword #:component - #:getter get-colour-component)) - - -(define (colour-component-id? a) - (is-a? a <colour-component-id>)) - - -(define (colour-component-id a) - (make <colour-component-id> - #:component a)) - - -(define (extract-colour-component col component-id) - (cond - ((eq? (get-colour-component component-id) 'cyan) - (cyan (colour-as-cmy col))) - ((eq? (get-colour-component component-id) 'magenta) - (magenta (colour-as-cmy col))) - ((eq? (get-colour-component component-id) 'yellow) - (yellow (colour-as-cmy col))) - ((eq? (get-colour-component component-id) 'red) - (red (colour-as-rgb col))) - ((eq? (get-colour-component component-id) 'green) - (green (colour-as-rgb col))) - ((eq? (get-colour-component component-id) 'blue) - (blue (colour-as-rgb col))) - (else (raise-exception (make-exception - (make-exception-with-message - "Invalid colour component ID") - (make-exception-with-irritants - (get-colour-component component-id))))))) diff --git a/guile/starlet/crossfade.scm b/guile/starlet/crossfade.scm new file mode 100644 index 0000000..65393b7 --- /dev/null +++ b/guile/starlet/crossfade.scm @@ -0,0 +1,261 @@ +;; +;; starlet/crossfade.scm +;; +;; Copyright © 2020-2023 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 crossfade) + #:use-module (oop goops) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (ice-9 exceptions) + #:use-module (starlet clock) + #:use-module (starlet cue-part) + #:use-module (starlet colours) + #:use-module (starlet fixture) + #:use-module (starlet state) + #:use-module (starlet attributes) + #:export (crossfade)) + + +(define-record-type <fade-times> + (make-fade-times up-time + down-time + attr-time + up-delay + down-delay + attr-delay) + fade-times? + (up-time get-fade-up-time) + (down-time get-fade-down-time) + (attr-time get-fade-attr-time) + (up-delay get-fade-up-delay) + (down-delay get-fade-down-delay) + (attr-delay get-fade-attr-delay)) + + +(define (snap-fade start-val + target-val + clock) + (if (> (elapsed-fraction clock) 0) + target-val + start-val)) + + +(define (colour-fade start-val + end-val + clock) + + (unless (and (colour? start-val) + (colour? end-val)) + (raise-exception (make-exception + (make-exception-with-message + "Non-colour arguments given to colour-fade") + (make-exception-with-irritants + (list start-val end-val))))) + + (interpolate-colour start-val + end-val + (elapsed-fraction clock) + #:interpolation-type 'linear-cmy)) + + +(define (simple-fade start-val + end-val + clock) + + (unless (and (number? start-val) + (number? end-val)) + (raise-exception (make-exception + (make-exception-with-message + "Non-number arguments given to simple-fade") + (make-exception-with-irritants + (list start-val end-val))))) + + (+ start-val + (* (- end-val start-val) + (elapsed-fraction clock)))) + + +(define (replace-noval val replacement) + (if (eq? 'no-value val) replacement val)) + + +(define (make-intensity-fade prev-val + target-val-in + up-clock + down-clock) + (let ((target-val (replace-noval target-val-in 0.0))) + + (cond + + ;; Number to number, fading up + ((and (number? target-val) + (number? prev-val) + (> target-val prev-val)) + (lambda () + (simple-fade prev-val + target-val + up-clock))) + + ;; Number to number, fading down + ((and (number? target-val) + (number? prev-val) + (< target-val prev-val)) + (lambda () + (simple-fade prev-val + target-val + down-clock))) + + ;; Number to number, staying the same + ;; NB We still need a static value so that fade-start-val can "unwrap" it + ((and (number? target-val) + (number? prev-val)) + (lambda () prev-val)) + + ;; Everything else, e.g. number to effect + (else + (lambda () + (max + (simple-fade (value->number prev-val) + 0 + down-clock) + (simple-fade 0 + (value->number target-val) + up-clock))))))) + + +(define (make-list-attr-fade start-val + target-val + clock) + (lambda () + (snap-fade start-val + target-val + clock))) + + +(define (make-general-fade fade-func + start-val + target-val + clock) + + (if (and (not (procedure? target-val)) + (not (eq? target-val 'no-value)) + (not (eq? start-val 'no-value))) + + ;; It makes sense to do a fade + (let ((real-start-val (value->number start-val))) + (lambda () + (fade-func real-start-val + target-val + clock))) + + ;; A fade doesn't make sense, so make do with a snap transition + (lambda () + (snap-fade start-val + target-val + clock)))) + + +(define (fade-start-val pb fix attr) + (let ((val-in-pb (state-find fix attr pb))) + (if (eq? val-in-pb 'no-value) + + ;; Not currently in playback - fade from home value + (get-attr-home-val fix attr) + + ;; Currently in playback - fade from current value + ;; by running the outer crossfade function + (val-in-pb)))) + + +(define (dark? a) + (or (eq? a 'no-value) + (and (number? a) + (< a 1)))) + + +(define (make-fade-for-attribute-type type) + (cond + ((eq? type 'continuous) (cut make-general-fade simple-fade <...>)) + ((eq? type 'list) make-list-attr-fade) + ((eq? type 'colour) (cut make-general-fade colour-fade <...>)) + (else + (raise-exception (make-exception + (make-exception-with-message + "Unrecognised attribute type") + (make-exception-with-irritants type)))))) + + +(define* (crossfade-real incoming-state up-time #:optional (down-time up-time) + #:key + (attr-time (min up-time down-time)) + (up-delay 0) + (down-delay 0) + (attr-delay 0)) + (cue-part + incoming-state + (lambda (incoming-state current-state clock) + (let ((up-clock (make-delayed-clock clock up-delay up-time)) + (down-clock (make-delayed-clock clock down-delay down-time)) + (attribute-clock (make-delayed-clock clock attr-delay attr-time))) + (let ((overlay-state (make-empty-state))) + (state-for-each + (lambda (fixture attr target-val) + + (let ((start-val (fade-start-val current-state fixture attr))) + + (if (intensity? attr) + + ;; Intensity attribute + (set-in-state! overlay-state fixture attr + (make-intensity-fade start-val + target-val + up-clock + down-clock)) + + ;; Non-intensity attribute + (let ((attribute-obj (find-attr fixture attr))) + + (unless attribute-obj + (raise-exception (make-exception + (make-exception-with-message + "Attribute not found") + (make-exception-with-irritants + (list fixture attr))))) + + (let* ((atype (get-attr-type attribute-obj)) + (make-fade-func (make-fade-for-attribute-type atype))) + + (set-in-state! overlay-state fixture attr + (make-fade-func start-val + target-val + attribute-clock))))))) + + incoming-state) + (values overlay-state + (max + (+ up-time up-delay) + (+ down-time down-delay) + (+ attr-time attr-delay)))))))) + + +;; Rearrange the arguments to put the lighting state (last argument) +;; at the beginning. This makes optional arguments in crossfade-real possible. +(define (crossfade . args) + (apply crossfade-real (last args) (drop-right args 1))) diff --git a/guile/starlet/cue-list.scm b/guile/starlet/cue-list.scm new file mode 100644 index 0000000..b029713 --- /dev/null +++ b/guile/starlet/cue-list.scm @@ -0,0 +1,217 @@ +;; +;; 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 attributes) + #:use-module (starlet cue-part) + #:use-module (starlet snap-transition) + #:use-module (starlet crossfade) + #:export (cue + cue-list + qnum + get-cue-number + get-cue-parts + get-cue-clock + get-preset-state + cue-number-to-index + cue-index-to-number + current-cue-clock + read-cue-list-file + num-cues) + #:re-export (snap crossfade)) + + +(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-method (num-cues (l <vector>)) + (vector-length l)) + + +(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->list + (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 current-cue-clock (make-parameter #f)) + +(define-syntax cue + (syntax-rules (track-intensities) + ((_ number track-intensities body ...) + (parameterize ((current-cue-clock (make-clock #:stopped #t))) + (make-cue (qnum number) + #f ;; preset state, to be filled later + #t ;; DO track intensities + (list body ...) + (current-cue-clock)))) + ((_ number body ...) + (parameterize ((current-cue-clock (make-clock #:stopped #t))) + (make-cue (qnum number) + #f ;; preset state, to be filled later + #f ;; don't track intensities + (list body ...) + (current-cue-clock)))))) + + +(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) + (lighting-state + (apply-state the-tracked-state) + (for-each + (lambda (part) + (apply-state (get-cue-part-state part))) + (cdr (get-cue-parts the-cue)))))) + (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 + (list->vector + (remove unspecified? + (list + (cue 0 (snap blackout)) + 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))))) diff --git a/guile/starlet/cue-part.scm b/guile/starlet/cue-part.scm new file mode 100644 index 0000000..e98e422 --- /dev/null +++ b/guile/starlet/cue-part.scm @@ -0,0 +1,35 @@ +;; +;; starlet/cue-part +;; +;; Copyright © 2020-2023 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-part) + #:use-module (srfi srfi-9) + #:export (cue-part + <cue-part> + get-cue-part-state + get-cue-part-transition + set-cue-part-state!)) + + +(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)) diff --git a/guile/starlet/effects.scm b/guile/starlet/effects.scm index c14f5a0..0a23dee 100644 --- a/guile/starlet/effects.scm +++ b/guile/starlet/effects.scm @@ -20,8 +20,11 @@ ;; (define-module (starlet effects) #:use-module (starlet clock) + #:use-module (starlet state) + #:use-module (starlet attributes) #:export (flash - sinewave)) + sinewave + flash-chase)) (define pi (* 2 (acos 0))) @@ -45,3 +48,25 @@ (+ range-min (* (/ (- range-max range-min) 2) (+ 1 (sin (* 2 pi hz (elapsed-time clock))))))))) + + +(define (hump t on-time) + (cond + ((< t 0.0) 0.0) + ((> t on-time) 0.0) + (else (* 100 (sin (* pi (/ t on-time))))))) + + +(define* (flash-chase group + #:key (repeat-time 2) (offset-time 0.3) (on-time 0.5)) + (let ((clock (make-clock))) + (for-each + (lambda (fix idx) + (at fix intensity + (lambda () + (hump (- (euclidean-remainder (elapsed-time clock) + repeat-time) + (* idx offset-time)) + on-time)))) + group + (iota (length group))))) diff --git a/guile/starlet/engine.scm b/guile/starlet/engine.scm new file mode 100644 index 0000000..fcd63a5 --- /dev/null +++ b/guile/starlet/engine.scm @@ -0,0 +1,227 @@ +;; +;; starlet/engine.scm +;; +;; Copyright © 2020-2023 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 engine) + #:use-module (starlet fixture) + #:use-module (starlet state) + #:use-module (starlet utils) + #:use-module (starlet attributes) + #:use-module (oop goops) + #:use-module (ice-9 threads) + #:use-module (ice-9 atomic) + #:use-module (ice-9 exceptions) + #:use-module (srfi srfi-1) + #:export (patch-fixture! + patch-many! + engine-freq + total-num-attrs + register-state! + current-value + current-value-state + patched-fixture-names + patched-fixtures)) + + +;; The list of patched fixtures +(define fixtures (make-atomic-box '())) + +;; List of states being scanned out +(define state-list (make-atomic-box '())) + +;; Association list of names to states +(define state-names (make-atomic-box '())) + +;; Current values (literal, not functions) of active attributes +(define current-values (make-atomic-box (make-empty-state))) + + +(define (patched-fixture-names) + (map get-fixture-name (atomic-box-ref fixtures))) + + +(define (current-value-state) + (atomic-box-ref current-values)) + + +(define (patched-fixtures) + (atomic-box-ref fixtures)) + + +(define (total-num-attrs) + (fold (lambda (fix prev) + (+ prev (length (get-fixture-attrs fix)))) + 0 + (atomic-box-ref fixtures))) + + +(define (get-state-name st) + (assq-ref (atomic-box-ref state-names) + st)) + + +(define (set-state-name! st name) + (atomic-box-set! state-names + (assq-set! (atomic-box-ref state-names) + st + name))) + + +;; Patch a new fixture +(define* (patch-real name + class + start-addr + #:key (universe 0)) + (let ((new-fixture (make class + #:name name + #:sa start-addr + #:uni universe))) + (atomic-box-set! fixtures (cons new-fixture + (atomic-box-ref fixtures))) + new-fixture)) + + +(define-syntax patch-fixture! + (syntax-rules () + ((_ name stuff ...) + (define name (patch-real (quote name) stuff ...))))) + + +;; Patch several new fixtures +(define* (patch-many-real name + class + start-addrs + #:key (universe 0)) + (map (lambda (start-addr n) + (patch-real `(list-ref ,name ,n) + class + start-addr + #:universe universe)) + start-addrs + (iota (length start-addrs)))) + + +(define-syntax patch-many! + (syntax-rules () + ((_ name stuff ...) + (define name (patch-many-real (quote name) stuff ...))))) + + +(define (current-value fix attr-name) + (let ((v (state-find fix attr-name (current-value-state)))) + (if (eq? v 'no-value) + (get-attr-home-val fix attr-name) + v))) + + +(define (append-or-replace-named-state orig-list name new-state) + (let ((new-list (map (lambda (st) + (if (eq? (get-state-name st) name) + (begin + new-state) + st)) + orig-list))) + + ;; If there is no state with this name in the list, + ;; the replacement above will have no effect. + ;; Check again and add in the normal way if so. + (if (find (lambda (st) (eq? (get-state-name st) + name)) + new-list) + new-list + (append orig-list (list new-state))))) + + +(define* (register-state! new-state + #:key (unique-name #f)) + (if unique-name + (begin (set-state-name! new-state unique-name) + (atomic-box-set! state-list + (append-or-replace-named-state (atomic-box-ref state-list) + unique-name + new-state))) + (atomic-box-set! state-list + (append (atomic-box-ref state-list) + (list new-state))))) + + +(define engine-thread #f) +(define engine-freq 0) + + +(define (htp-attr? attr) + (eq? attr intensity)) + + +(define (engine-loop start-time count) + + ;; Combine all the active attributes and send it out + (atomic-box-swap! current-values + (combine-states + (let ((states (atomic-box-ref state-list))) + (for-each update-state! states) + (fold + (lambda (incoming-state combined-state) + (state-for-each + (lambda (fix attr val) + (let ((incoming-val (value->number val)) + (current-val (state-find fix attr combined-state))) + (unless (eq? incoming-val 'no-value) + (if (eq? current-val 'no-value) + (set-in-state! combined-state fix attr incoming-val) + (set-in-state! combined-state fix attr + (if (htp-attr? attr) + (max incoming-val current-val) + incoming-val)))))) + incoming-state) + combined-state) + (make-empty-state) + states)) + programmer-state)) + + (usleep 20000) + + ;; Update output rate every 1000 cycles + (if (eq? count 100) + (begin + (set! engine-freq + (exact->inexact (/ 100 + (- (hirestime) start-time)))) + (engine-loop (hirestime) 0)) + (engine-loop start-time (+ count 1)))) + + +(define (start-engine) + (if engine-thread + (format #t "Engine thread is already running\n") + (let ((start-time (hirestime))) + (set! engine-thread + (begin-thread + (with-exception-handler + (lambda (exn) + (display "Error in engine thread:\n") + (set! engine-thread #f) + (backtrace) + (raise-exception exn)) + (lambda () + (engine-loop start-time 0)) + #:unwind? #f)))))) + + +(start-engine) diff --git a/guile/starlet/fixture-library/adj/mega-tripar-profile.scm b/guile/starlet/fixture-library/adj/mega-tripar-profile.scm new file mode 100644 index 0000000..4815fa9 --- /dev/null +++ b/guile/starlet/fixture-library/adj/mega-tripar-profile.scm @@ -0,0 +1,63 @@ +;; +;; starlet/fixture-library/adj/mega-tripar-profile.scm +;; +;; Copyright © 2020-2022 Thomas White <taw@bitwiz.me.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 fixture-library adj mega-tripar-profile) + #:use-module (starlet scanout) + #:use-module (starlet fixture) + #:use-module (starlet attributes) + #:use-module (starlet utils) + #:use-module (starlet colours) + #:export (<adj-mega-tripar-profile-3ch> + <adj-mega-tripar-profile-4ch>)) + + +;; 3 channel mode (RGB direct control) + +(define-fixture + + <adj-mega-tripar-profile-3ch> + + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-colour colour white)) + + (let ((intensity (/ (get-attr intensity) 100)) + (rgb (colour-as-rgb (get-attr colour)))) + (set-chan8 1 (percent->dmxval8 (* intensity (car rgb)))) + (set-chan8 2 (percent->dmxval8 (* intensity (cadr rgb)))) + (set-chan8 3 (percent->dmxval8 (* intensity (caddr rgb)))))) + + +;; 4 channel mode (RGB + separate intensity) + +(define-fixture + + <adj-mega-tripar-profile-4ch> + + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-colour colour white)) + + (let ((rgb (colour-as-rgb (get-attr colour)))) + (set-chan8 1 (percent->dmxval8 (get-attr intensity))) + (set-chan8 2 (percent->dmxval8 (car rgb))) + (set-chan8 3 (percent->dmxval8 (cadr rgb))) + (set-chan8 4 (percent->dmxval8 (caddr rgb))))) + diff --git a/guile/starlet/fixture-library/chauvet/mav2.scm b/guile/starlet/fixture-library/chauvet/mav2.scm new file mode 100644 index 0000000..5fae168 --- /dev/null +++ b/guile/starlet/fixture-library/chauvet/mav2.scm @@ -0,0 +1,50 @@ +;; +;; starlet/fixture-library/chauvet.scm +;; +;; Copyright © 2020-2021 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 fixture-library chauvet mav2) + #:use-module (starlet scanout) + #:use-module (starlet fixture) + #:use-module (starlet attributes) + #:use-module (starlet utils) + #:use-module (starlet colours) + #:export (<chauvet-mav2-32ch>)) + + +(define-fixture + + <chauvet-mav2-32ch> + + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-continuous pan '(0 540) 270) + (attr-continuous tilt '(0 270) 135) + (attr-continuous cyan '(0 100) 0) + (attr-continuous magenta '(0 100) 0) + (attr-continuous yellow '(0 100) 0)) + + (set-chan-16bit 1 (get-attr pan) 540) + (set-chan-16bit 3 (get-attr tilt) 270) + (set-chan-16bit 6 (get-attr intensity) 100) + + (set-chan 10 (percent->dmxval (get-attr cyan))) + (set-chan 11 (percent->dmxval (get-attr magenta))) + (set-chan 12 (percent->dmxval (get-attr yellow))) + + (set-chan 8 255)) diff --git a/guile/starlet/fixture-library/chauvet/mav2/32chan.scm b/guile/starlet/fixture-library/chauvet/mav2/32chan.scm deleted file mode 100644 index 5868587..0000000 --- a/guile/starlet/fixture-library/chauvet/mav2/32chan.scm +++ /dev/null @@ -1,49 +0,0 @@ -;; -;; starlet/fixture-library/chauvet.scm -;; -;; Copyright © 2020-2021 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 fixture-library chauvet) - #:use-module (oop goops) - #:use-module (starlet fixture) - #:export (<chauvet-mav2-32ch>)) - - -(define-class <chauvet-mav2-32ch> (<fixture>) - (attributes - #:init-form (list - (attr-continuous 'intensity '(0 100) 0) - (attr-continuous 'pan '(0 540) 270) - (attr-continuous 'tilt '(0 270) 135) - (attr-continuous 'cyan '(0 100) 0) - (attr-continuous 'magenta '(0 100) 0) - (attr-continuous 'yellow '(0 100) 0)))) - - -(define-method (scanout-fixture (fixture <chauvet-mav2-32ch>) - get-attr set-chan set-chan-16bit) - - (set-chan-16bit 1 (get-attr 'pan) 540) - (set-chan-16bit 3 (get-attr 'tilt) 270) - (set-chan-16bit 6 (get-attr 'intensity) 100) - - (set-chan 10 (percent->dmxval (get-attr 'cyan))) - (set-chan 11 (percent->dmxval (get-attr 'magenta))) - (set-chan 12 (percent->dmxval (get-attr 'yellow))) - - (set-chan 8 255)) diff --git a/guile/starlet/fixture-library/generic/any-rgb.scm b/guile/starlet/fixture-library/generic/any-rgb.scm deleted file mode 100644 index 1fc3fe2..0000000 --- a/guile/starlet/fixture-library/generic/any-rgb.scm +++ /dev/null @@ -1,62 +0,0 @@ -;; -;; starlet/fixture-library/generic/any-rgb.scm -;; -;; Copyright © 2020-2021 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 fixture-library generic any-rgb) - #:use-module (oop goops) - #:use-module (starlet fixture) - #:export (make-any-rgb)) - - -(define (chan->attr chan) - (attr-continuous chan '(0 100) 0)) - - -(define (make-any-rgb chans) - - (let ((new-class (make-class - (list <fixture>) - (list (cons 'attributes - (list #:init-thunk - (lambda () - (map chan->attr chans))))) - #:name 'generic-rgb))) - - (add-method! - scanout-fixture - (method ((fix new-class) get-attr set-chan8 set-chan16) - (for-each - - (lambda (chan offset) - - (cond - - ((eq? chan '0) - (set-chan8 offset 0)) - - ((eq? chan 'FL) - (set-chan8 offset 255)) - - (else (set-chan8 offset - (percent->dmxval8 - (get-attr chan)))))) - - chans (iota (length chans) 1)))) - - new-class)) diff --git a/guile/starlet/fixture-library/generic/dimmer.scm b/guile/starlet/fixture-library/generic/dimmer.scm index 65e6d99..6b25c15 100644 --- a/guile/starlet/fixture-library/generic/dimmer.scm +++ b/guile/starlet/fixture-library/generic/dimmer.scm @@ -1,7 +1,7 @@ ;; ;; starlet/fixture-library/generic/dimmer.scm ;; -;; Copyright © 2020-2021 Thomas White <taw@bitwiz.org.uk> +;; Copyright © 2020-2022 Thomas White <taw@bitwiz.org.uk> ;; ;; This file is part of Starlet. ;; @@ -19,20 +19,18 @@ ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;; (define-module (starlet fixture-library generic dimmer) - #:use-module (oop goops) + #:use-module (starlet scanout) #:use-module (starlet fixture) + #:use-module (starlet utils) + #:use-module (starlet attributes) #:export (<generic-dimmer>)) +(define-fixture -(define-class <generic-dimmer> (<fixture>) - (attributes - #:init-form (list - (attr-continuous 'intensity '(0 100) 0)))) + <generic-dimmer> + (fixture-attributes + (attr-continuous intensity '(0 100) 0)) -(define-method (scanout-fixture (fixture <generic-dimmer>) - get-attr set-chan8 set-chan16) - - ;; Set DMX value for intensity - (set-chan8 1 (percent->dmxval8 (get-attr 'intensity)))) + (set-chan8 1 (percent->dmxval8 (get-attr intensity)))) diff --git a/guile/starlet/fixture-library/generic/rgb.scm b/guile/starlet/fixture-library/generic/rgb.scm index 6fa281d..1b292af 100644 --- a/guile/starlet/fixture-library/generic/rgb.scm +++ b/guile/starlet/fixture-library/generic/rgb.scm @@ -1,7 +1,7 @@ ;; ;; starlet/fixture-library/generic/rgb.scm ;; -;; Copyright © 2020-2021 Thomas White <taw@bitwiz.org.uk> +;; Copyright © 2020-2022 Thomas White <taw@bitwiz.org.uk> ;; ;; This file is part of Starlet. ;; @@ -19,24 +19,24 @@ ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;; (define-module (starlet fixture-library generic rgb) - #:use-module (oop goops) + #:use-module (starlet scanout) #:use-module (starlet fixture) + #:use-module (starlet attributes) + #:use-module (starlet utils) #:use-module (starlet colours) #:export (<generic-rgb>)) -(define-class <generic-rgb> (<fixture>) - (attributes - #:init-form (list - (attr-continuous 'intensity '(0 100) 0) - (attr-colour 'colour white)))) +(define-fixture + <generic-rgb> -(define-method (scanout-fixture (fixture <generic-rgb>) - get-attr set-chan8 set-chan16) + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-colour colour white)) - (let ((intensity (get-attr 'intensity)) - (rgb (colour-as-rgb (get-attr 'colour)))) + (let ((intensity (get-attr intensity)) + (rgb (colour-as-rgb (get-attr colour)))) (set-chan8 1 (percent->dmxval8 (* intensity 0.01 (car rgb)))) (set-chan8 2 (percent->dmxval8 (* intensity 0.01 (cadr rgb)))) (set-chan8 3 (percent->dmxval8 (* intensity 0.01 (caddr rgb)))))) diff --git a/guile/starlet/fixture-library/lightmaxx/led-cob.scm b/guile/starlet/fixture-library/lightmaxx/led-cob.scm new file mode 100644 index 0000000..5ce5879 --- /dev/null +++ b/guile/starlet/fixture-library/lightmaxx/led-cob.scm @@ -0,0 +1,45 @@ +;; +;; starlet/fixture-library/lightmaxx-led-cob.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 fixture-library lightmaxx led-cob) + #:use-module (starlet scanout) + #:use-module (starlet fixture) + #:use-module (starlet attributes) + #:use-module (starlet colours) + #:use-module (starlet utils) + #:use-module (starlet attributes) + #:export (<lightmaxx-ledcob-5ch>)) + +(define-fixture + + <lightmaxx-ledcob-5ch> + + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-colour colour white)) + + (let ((intensity (get-attr intensity)) + (rgb (colour-as-rgb (get-attr colour)))) + (set-chan8 1 (percent->dmxval8 (car rgb))) + (set-chan8 2 (percent->dmxval8 (cadr rgb))) + (set-chan8 3 (percent->dmxval8 (caddr rgb))) + (set-chan8 4 (percent->dmxval8 intensity)) + (set-chan8 5 0))) + diff --git a/guile/starlet/fixture-library/robe/dl7s.scm b/guile/starlet/fixture-library/robe/dl7s.scm new file mode 100644 index 0000000..0f9b10d --- /dev/null +++ b/guile/starlet/fixture-library/robe/dl7s.scm @@ -0,0 +1,241 @@ +;; +;; starlet/fixture-library/robe/dl7s/mode1.scm +;; +;; Copyright © 2020-2023 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 fixture-library robe dl7s) + #:use-module (oop goops) + #:use-module (starlet fixture) + #:use-module (starlet utils) + #:use-module (starlet attributes) + #:use-module (starlet colours) + #:use-module (starlet scanout) + #:export (<robe-dl7s-mode1>)) + + +(define virtual-colour-wheel + '((#f 0) + (lee4-medium-bastard-amber 2) + (lee10-medium-yellow 4) + (lee19-fire 6) + (lee26-bright-red 8) + (lee58-lavender 10) + (lee68-sky-blue 12) + (lee71-tokyo-blue 14) + (lee79-just-blue 16) + (lee88-lime-green 18) + (lee90-dark-yellow-green 20) + (lee100-spring-yellow 22) + (lee101-yellow 24) + (lee102-light-amber 26) + (lee103-straw 28) + (lee104-deep-amber 30) + (lee105-orange 32) + (lee106-primary-red 34) + (lee111-dark-pink 36) + (lee115-peacock-blue 38) + (lee116-medium-blue-green 40) + (lee117-steel-blue 42) + (lee118-light-blue 44) + (lee119-dark-blue 46) + (lee120-deep-blue 48) + (lee121-lee-green 50) + (lee128-bright-pink 52) + (lee131-marine-blue 54) + (lee132-medium-blue 56) + (lee134-golden-amber 58) + (lee135-deep-golden-amber 60) + (lee136-pale-lavender 62) + (lee137-special-lavender 64) + (lee138-pale-green 66) + (lee139-primary-green 68) + (lee141-bright-blue 70) + (lee147-apricot 72) + (lee148-bright-rose 74) + (lee152-pale-gold 76) + (lee154-pale-rose 78) + (lee157-pink 80) + (lee158-deep-orange 82) + (lee162-bastard-amber 84) + (lee164-flame-red 86) + (lee165-daylight-blue 88) + (lee169-lilac-tint 90) + (lee170-deep-lavender 92) + (lee172-lagoon-blue 94) + (lee179-chrome-orange 96) + (lee180-dark-lavender 98) + (lee181-congo-blue 100) + (lee197-alice-blue 102) + (lee201-full-ct-blue 104) + (lee202-half-ct-blue 106) + (lee203-quarter-ct-blue 108) + (lee204-full-ct-orange 110) + (lee205-half-ct-orange 112) + (lee206-quarter-ct-orange 114) + (lee247-lee-minus-green 116) + (lee247-half-minus-green 118) + (lee281-threequarter-ct-blue 120) + (lee285-threequarter-ct-orange 122) + (lee352-glacier-blue 124) + (lee353-lighter-blue 126) + (lee715-cabana-blue 128) + (lee778-millennium-gold 130) + (lee793-vanity-fair 132) + (deep-red 193) + (deep-blue 195) + (orange 197) + (green 199) + (magenta 201) + (congo-blue 203) + (pink 205) + (lavender 207) + (laser-green 209) + (ctb 211) + (minus-green 213) + (minus-half-green 215))) + +(define static-gobo-wheel + '((#f 0) + (water 7) + (rugged-isles 14) + (quadrangle-screen 21) + (whirl 28) + (breakup 36) + (blur-breakup 43) + (knitting 50) + (grit 57))) + +(define rotating-gobo-wheel + '((#f 0) + (rose 7) + (water-line 11) + (tree-trunk 15) + (high-window 20) + (grid 24) + (clouds 29))) + + +;; FIXME: Gobo shaking (both wheels) +;; FIXME: Rainbow effect on colour wheel (???) +;; FIXME: Fine control iris, zoom +(define-fixture + + <robe-dl7s-mode1> + + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-continuous pan '(0 540) 270) + (attr-continuous tilt '(0 270) 135) + (attr-list strobe '(#f on random) #f) + (attr-continuous strobe-frequency '(0 25) 25 "Frequencies not calibrated") + (attr-list prism '(#t #f) #f) + (attr-colour colour white) + (attr-list colwheel (map car virtual-colour-wheel) #f "Has priority over 'colour' attribute") + (attr-continuous colour-temperature '(2700 8000) 3200) + (attr-list animation-wheel '(#t #f) #f) + (attr-continuous animation-wheel-position '(-100 100) 0) + (attr-continuous animation-wheel-speed '(-100 100) 0) + (attr-list gobo (map car static-gobo-wheel) #f) + (attr-continuous gobo-shift '(0 100) 0) + (attr-list rotating-gobo (map car rotating-gobo-wheel) #f) + (attr-continuous rotating-gobo-speed '(-100 100) 0) + (attr-continuous prism-rotation-speed '(-100 100) 0) + (attr-continuous frost '(0 100) 0) + (attr-continuous zoom '(0 100) 50) + (attr-continuous iris '(0 100) 0) + (attr-continuous barndoor-all-rotation '(-45 45) 0) + (attr-continuous barndoor1 '(0 100) 0) + (attr-continuous barndoor2 '(0 100) 0) + (attr-continuous barndoor3 '(0 100) 0) + (attr-continuous barndoor4 '(0 100) 0) + (attr-continuous barndoor1-rotation '(-25 25) 0) + (attr-continuous barndoor2-rotation '(-25 25) 0) + (attr-continuous barndoor3-rotation '(-25 25) 0) + (attr-continuous barndoor4-rotation '(-25 25) 0) + (attr-continuous focus '(0 100) 50)) + + (set-chan16 1 (scale-to-range (get-attr pan) '(0 540) '(0 65535))) + (set-chan16 3 (scale-to-range (get-attr tilt) '(0 270) '(0 65535))) + + (set-chan8 5 0) ;; Pan/tilt speed/time: maximum speed + (set-chan8 6 0) ;; Power/special function: default + (set-chan8 7 0) ;; Colour mode: default + + (set-chan8 8 (lookup (get-attr colwheel) virtual-colour-wheel)) + + (let ((cmy (colour-as-cmy (get-attr colour)))) + (set-chan16 9 (percent->dmxval16 (cyan cmy))) + (set-chan16 11 (percent->dmxval16 (magenta cmy))) + (set-chan16 13 (percent->dmxval16 (yellow cmy)))) + + (set-chan8 15 + (scale-and-clamp-to-range (get-attr colour-temperature) + '(8000 2700) '(0 255))) + + (set-chan8 16 0) ;; Green correction: uncorrected white + (set-chan8 17 0) ;; Colour mix control: virtual colour wheel has priority + (set-chan8 18 0) ;; Rotating gobo selection speed: maximum + (set-chan8 19 0) ;; Everything time: off (???) + + (let ((ani-active (get-attr animation-wheel))) + (set-chan8 20 (if ani-active + (scale-to-range (get-attr animation-wheel-position) + '(-100 100) '(19 127)) + 0)) ;; 73 = stop + (set-chan8 21 (scale-to-range (get-attr animation-wheel-speed) + '(100 -100) '(1 255)))) ;; 128 = stop + (set-chan8 22 0) ;; Animation wheel macro: no function + + (set-chan8 23 (lookup (get-attr gobo) static-gobo-wheel)) + (set-chan8 24 (percent->dmxval8 (get-attr gobo-shift))) + + (set-chan8 25 (lookup (get-attr rotating-gobo) rotating-gobo-wheel)) + (set-chan8 26 (scale-to-range (get-attr rotating-gobo-speed) + '(-100 100) '(1 255))) ;; 128 = stop + (set-chan8 27 0) ;; Rotating gobo fine adjustment (default) + + (set-chan8 28 (if (get-attr prism) 50 0)) + (set-chan8 29 (scale-to-range (get-attr prism-rotation-speed) + '(100 -100) '(1 255))) ;; 128 = stop, <128=forwards + (set-chan8 30 (scale-to-range (get-attr frost) '(0 100) '(0 180))) + (set-chan8 31 (scale-to-range (get-attr iris) '(0 100) '(0 180))) + (set-chan16 33 (percent->dmxval16 (get-attr zoom))) + (set-chan16 35 (percent->dmxval16 (get-attr focus))) + + (set-chan8 38 (scale-to-range (get-attr barndoor-all-rotation) '(-45 45) '(0 255))) + (set-chan8 39 (percent->dmxval8 (get-attr barndoor1))) + (set-chan8 40 (scale-to-range (get-attr barndoor1-rotation) '(-25 25) '(0 255))) + (set-chan8 41 (percent->dmxval8 (get-attr barndoor2))) + (set-chan8 42 (scale-to-range (get-attr barndoor2-rotation) '(-25 25) '(0 255))) + (set-chan8 43 (percent->dmxval8 (get-attr barndoor3))) + (set-chan8 44 (scale-to-range (get-attr barndoor3-rotation) '(-25 25) '(0 255))) + (set-chan8 45 (percent->dmxval8 (get-attr barndoor4))) + (set-chan8 46 (scale-to-range (get-attr barndoor4-rotation) '(-25 25) '(0 255))) + (set-chan8 47 0) ;; Framing shutter macro: no function + (set-chan8 48 128) ;; Framing shutter macro speed: default + + (let ((strb (get-attr strobe))) + (set-chan8 49 + (cond + ((not strb) 32) + ((eq? strb 'on) + (scale-to-range (get-attr strobe-frequency) '(1 25) '(64 95))) + ((eq? strb 'random) + (scale-to-range (get-attr strobe-frequency) '(1 25) '(192 223)))))) + + (set-chan16 50 (percent->dmxval16 (get-attr intensity)))) diff --git a/guile/starlet/fixture-library/robe/dl7s/mode1.scm b/guile/starlet/fixture-library/robe/dl7s/mode1.scm deleted file mode 100644 index e9d5a9a..0000000 --- a/guile/starlet/fixture-library/robe/dl7s/mode1.scm +++ /dev/null @@ -1,65 +0,0 @@ -;; -;; starlet/fixture-library/robe/dl7s/mode1.scm -;; -;; Copyright © 2020-2021 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 fixture-library robe dl7s mode1) - #:use-module (oop goops) - #:use-module (starlet fixture) - #:use-module (starlet colours) - #:export (<robe-dl7s-mode1>)) - - -(define-class <robe-dl7s-mode1> (<fixture>) - (attributes - #:init-form (list - (attr-continuous 'intensity '(0 100) 0) - (attr-continuous 'pan '(0 540) 270) - (attr-continuous 'tilt '(0 270) 135) - (attr-list 'strobe '(#t #f) #f) - (attr-list 'prism '(#t #f) #f) - (attr-list 'tungsten-watts-emulation '(750 1000 1200 2000 2500 #f) #f) - (attr-colour 'colour white) - (attr-continuous 'colour-temperature-correction '(2700 8000) 8000) - (attr-continuous 'green-correction '(-100 100) 0)))) - - -(define-method (scanout-fixture (fixture <robe-dl7s-mode1>) - get-attr set-chan8 set-chan16) - - (set-chan16 50 (percent->dmxval16 (get-attr 'intensity))) - - (set-chan16 1 (scale-to-range (get-attr 'pan) '(0 540) '(0 65535))) - (set-chan16 3 (scale-to-range (get-attr 'tilt) (0 270) '(0 65535))) - - (set-chan8 49 (if (get-attr 'strobe) 95 32)) - - (set-chan8 28 (if (get-attr 'prism) 50 0)) - - (set-chan8 7 (assv-ref '((750 . 82) - (1000 . 88) - (1200 . 92) - (2000 . 97) - (2500 . 102) - (#f . 107)) - (get-attr 'tungsten-watts-emulation))) - - (let ((cmy (colour-as-cmy (get-attr 'colour)))) - (set-chan8 9 (percent->dmxval8 (car cmy))) - (set-chan8 11 (percent->dmxval8 (cadr cmy))) - (set-chan8 13 (percent->dmxval8 (caddr cmy))))) diff --git a/guile/starlet/fixture-library/robe/mmxspot.scm b/guile/starlet/fixture-library/robe/mmxspot.scm new file mode 100644 index 0000000..1f37299 --- /dev/null +++ b/guile/starlet/fixture-library/robe/mmxspot.scm @@ -0,0 +1,87 @@ +;; +;; starlet/fixture-library/robe/mmxspot/mode1.scm +;; +;; Copyright © 2020-2021 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 fixture-library robe mmxspot) + #:use-module (oop goops) + #:use-module (starlet fixture) + #:use-module (starlet attributes) + #:use-module (starlet colours) + #:export (<robe-mmxspot-mode1>)) + + +(define-fixture + + <robe-mmxspot-mode1> + + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-continuous pan '(0 540) 270) + (attr-continuous tilt '(0 270) 135) + (attr-list colwheel '(#f red blue orange green amber uv) #f) + (attr-list prism '(#t #f) #f) + (attr-list strobe '(off on random zap) off) + (attr-continuous strobe-frequency '(0 100) 50) + (attr-colour colour white) + (attr-continuous iris '(0 100) 0) + (attr-continuous zoom '(0 100) 0) + (attr-continuous focus '(0 100) 0) + (attr-continuous hotspot '(0 100) 0) + (attr-continuous frost '(0 100) 0) + (attr-continuous cto '(3200 6900) 6900)) + + (set-chan16 37 (percent->dmxval16 (get-attr intensity))) + + (set-chan16 1 (scale-to-range (get-attr pan) '(0 540) '(0 65535))) + + (set-chan16 3 (scale-to-range (get-attr tilt) '(0 270) '(0 65535))) + + (set-chan16 28 (scale-to-range (get-attr iris) '(0 100) '(0 45567))) + (set-chan16 30 (percent->dmxval16 (get-attr zoom))) + (set-chan16 32 (percent->dmxval16 (get-attr focus))) + + (set-chan8 36 + (let ((strb (get-attr strobe)) + (spd (get-attr strobe-speed))) + (cond + ;; FIXME: Check the frequencies + ((eq? strb 'on) (scale-to-range spd '(0 100) '(64 95))) + ((eq? strb 'random) (scale-to-range spd '(0 100) '(192 223))) + ((eq? strb 'zap) (scale-to-range spd '(0 100) '(160 191))) + (else 255)))) + + (set-chan8 25 (if (get-attr prism) 20 0)) + + (set-chan8 7 (assv-ref '((#f . 0) + (red . 18) + (blue . 37) + (orange . 55) + (green . 73) + (amber . 91) + (uv . 110)) + (get-attr colwheel))) + + (let ((cmy (colour-as-cmy (get-attr colour)))) + (set-chan8 9 (percent->dmxval8 (car cmy))) + (set-chan8 10 (percent->dmxval8 (cadr cmy))) + (set-chan8 11 (percent->dmxval8 (caddr cmy)))) + + (set-chan8 35 (percent->dmxval8 (get-attr hotspot))) + (set-chan8 12 (scale-to-range (get-attr cto) '(3200 6900) '(0 255))) + (set-chan8 27 (scale-to-range (get-attr frost) '(0 100) '(0 179)))) diff --git a/guile/starlet/fixture-library/robe/mmxspot/mode1.scm b/guile/starlet/fixture-library/robe/mmxspot/mode1.scm deleted file mode 100644 index 9fedde4..0000000 --- a/guile/starlet/fixture-library/robe/mmxspot/mode1.scm +++ /dev/null @@ -1,87 +0,0 @@ -;; -;; starlet/fixture-library/robe/mmxspot/mode1.scm -;; -;; Copyright © 2020-2021 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 fixture-library robe mmxspot mode1) - #:use-module (oop goops) - #:use-module (starlet fixture) - #:use-module (starlet colours) - #:export (<robe-mmxspot-mode1>)) - - -(define-class <robe-mmxspot-mode1> (<fixture>) - (attributes - #:init-form (list - (attr-continuous 'intensity '(0 100) 0) - (attr-continuous 'pan '(0 540) 270) - (attr-continuous 'tilt '(0 270) 135) - (attr-list 'colwheel '(#f red blue orange green amber uv) #f) - (attr-list 'prism '(#t #f) #f) - (attr-list 'strobe '(#f #t random zap) #f) - (attr-continuous 'strobe-speed '(0 100) 50) - (attr-colour 'colour white) - (attr-continuous 'iris '(0 100) 0) - (attr-continuous 'zoom '(0 100) 0) - (attr-continuous 'focus '(0 100) 0) - (attr-continuous 'hotspot '(0 100) 0) - (attr-continuous 'frost '(0 100) 0) - (attr-continuous 'cto '(3200 6900) 6900)))) - - -(define-method (scanout-fixture (fixture <robe-mmxspot-mode1>) - get-attr set-chan8 set-chan16) - - (set-chan16 37 (percent->dmxval16 (get-attr 'intensity))) - - (set-chan16 1 (scale-to-range (get-attr 'pan) '(0 540) '(0 65535))) - - (set-chan16 3 (scale-to-range (get-attr 'tilt) '(0 270) '(0 65535))) - - (set-chan16 28 (scale-to-range (get-attr 'iris) '(0 100) '(0 45567))) - (set-chan16 30 (percent->dmxval16 (get-attr 'zoom))) - (set-chan16 32 (percent->dmxval16 (get-attr 'focus))) - - (set-chan8 36 - (let ((strb (get-attr 'strobe)) - (spd (get-attr 'strobe-speed))) - (cond - ((eq? strb #t) (scale-to-range spd '(0 100) '(64 95))) - ((eq? strb 'random) (scale-to-range spd '(0 100) '(192 223))) - ((eq? strb 'zap) (scale-to-range spd '(0 100) '(160 191))) - (else 255)))) - - (set-chan8 25 (if (get-attr 'prism) 20 0)) - - (set-chan8 7 (assv-ref '((#f . 0) - (red . 18) - (blue . 37) - (orange . 55) - (green . 73) - (amber . 91) - (uv . 110)) - (get-attr 'colwheel))) - - (let ((cmy (colour-as-cmy (get-attr 'colour)))) - (set-chan8 9 (percent->dmxval8 (car cmy))) - (set-chan8 10 (percent->dmxval8 (cadr cmy))) - (set-chan8 11 (percent->dmxval8 (caddr cmy)))) - - (set-chan8 35 (percent->dmxval8 (get-attr 'hotspot))) - (set-chan8 12 (scale-to-range (get-attr 'cto) '(3200 6900) '(0 255))) - (set-chan8 27 (scale-to-range (get-attr 'frost) '(0 100) '(0 179)))) diff --git a/guile/starlet/fixture-library/robe/mmxwashbeam.scm b/guile/starlet/fixture-library/robe/mmxwashbeam.scm new file mode 100644 index 0000000..a41c80d --- /dev/null +++ b/guile/starlet/fixture-library/robe/mmxwashbeam.scm @@ -0,0 +1,94 @@ +;; +;; starlet/fixture-library/robe/mmxwashbeam.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 fixture-library robe mmxwashbeam) + #:use-module (starlet scanout) + #:use-module (starlet fixture) + #:use-module (starlet attributes) + #:use-module (starlet utils) + #:use-module (starlet colours) + #:export (<robe-mmxwashbeam-mode1>)) + + +(define-fixture + + <robe-mmxwashbeam-mode1> + + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-continuous pan '(0 540) 270) + (attr-continuous tilt '(0 270) 135) + (attr-list strobe '(#t #f) #f) + (attr-list colwheel '(#f red blue orange green amber uv) #f) + (attr-list gobo '(#f iris gobo1 gobo2 gobo3 gobo4 gobo5 gobo6) #f) + (attr-list beamtype '(beam beamwash beamwashext) 'beam) + (attr-colour colour white) + (attr-continuous zoom '(0 100) 0) + (attr-continuous focus '(0 100) 0) + (attr-continuous barndoor-rot '(0 180) 90) + (attr-continuous barndoor1 '(0 180) 0) + (attr-continuous barndoor2 '(0 100) 0) + (attr-continuous barndoor3 '(0 100) 0) + (attr-continuous barndoor4 '(0 100) 0)) + + (set-chan16 33 (percent->dmxval16 (get-attr intensity))) + + (set-chan16 1 (scale-to-range (get-attr pan) '(0 540) '(0 65535))) + (set-chan16 3 (scale-to-range (get-attr tilt) '(0 270) '(0 65535))) + + (set-chan8 32 (if (get-attr strobe) 70 255)) + + (set-chan16 19 (percent->dmxval16 (get-attr zoom))) + (set-chan16 21 (percent->dmxval16 (get-attr focus))) + + ;;(set-chan 24 (number->dmxval (get-attr barndoor-rot) '(0 180))) + (set-chan8 25 (percent->dmxval8 (get-attr barndoor1))) + (set-chan8 26 (percent->dmxval8 (get-attr barndoor2))) + (set-chan8 27 (percent->dmxval8 (get-attr barndoor3))) + (set-chan8 28 (percent->dmxval8 (get-attr barndoor4))) + + (set-chan8 7 (assv-ref '((#f . 0) + (red . 18) + (blue . 37) + (orange . 55) + (green . 73) + (amber . 91) + (uv . 110)) + (get-attr colwheel))) + + (set-chan8 15 (assv-ref '((#f . 0) + (iris . 5) + (gobo1 . 10) + (gobo2 . 14) + (gobo3 . 18) + (gobo4 . 22) + (gobo5 . 26) + (gobo6 . 30)) + (get-attr gobo))) + + (set-chan8 18 (assv-ref '((beam . 0) + (beamwash . 35) + (beamwashext . 45)) + (get-attr beamtype))) + + (let ((cmy (colour-as-cmy (get-attr colour)))) + (set-chan8 9 (percent->dmxval8 (car cmy))) + (set-chan8 10 (percent->dmxval8 (cadr cmy))) + (set-chan8 11 (percent->dmxval8 (caddr cmy))))) diff --git a/guile/starlet/fixture-library/robe/mmxwashbeam/mode1.scm b/guile/starlet/fixture-library/robe/mmxwashbeam/mode1.scm deleted file mode 100644 index b412a24..0000000 --- a/guile/starlet/fixture-library/robe/mmxwashbeam/mode1.scm +++ /dev/null @@ -1,94 +0,0 @@ -;; -;; starlet/fixture-library/robe/mmxwashbeam/mode1.scm -;; -;; Copyright © 2020-2021 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 fixture-library robe mmxwashbeam mode1) - #:use-module (oop goops) - #:use-module (starlet fixture) - #:use-module (starlet colours) - #:export (<robe-mmxwashbeam-mode1>)) - - -(define-class <robe-mmxwashbeam-mode1> (<fixture>) - (attributes - #:init-form (list - (attr-continuous 'intensity '(0 100) 0) - (attr-continuous 'pan '(0 540) 270) - (attr-continuous 'tilt '(0 270) 135) - (attr-list 'strobe '(#t #f) #f) - (attr-list 'colwheel '(#f red blue orange green amber uv) #f) - (attr-list 'gobo '(#f iris gobo1 gobo2 gobo3 gobo4 gobo5 gobo6) #f) - (attr-list 'beamtype '(beam beamwash beamwashext) 'beam) - (attr-colour 'colour white) - (attr-continuous 'zoom '(0 100) 0) - (attr-continuous 'focus '(0 100) 0) - (attr-continuous 'barndoor-rot '(0 180) 90) - (attr-continuous 'barndoor1 '(0 180) 0) - (attr-continuous 'barndoor2 '(0 100) 0) - (attr-continuous 'barndoor3 '(0 100) 0) - (attr-continuous 'barndoor4 '(0 100) 0)))) - - -(define-method (scanout-fixture (fixture <robe-mmxwashbeam-mode1>) - get-attr set-chan8 set-chan16) - - (set-chan16 33 (percent->dmxval16 (get-attr 'intensity))) - - (set-chan16 1 (scale-to-range (get-attr 'pan) '(0 540) '(0 65535))) - (set-chan16 3 (scale-to-range (get-attr 'tilt) '(0 270) '(0 65535))) - - (set-chan8 32 (if (get-attr 'strobe) 70 255)) - - (set-chan16 19 (percent->dmxval16 (get-attr 'zoom))) - (set-chan16 21 (percent->dmxval16 (get-attr 'focus))) - - ;;(set-chan 24 (number->dmxval (get-attr 'barndoor-rot) '(0 180))) - (set-chan8 25 (percent->dmxval8 (get-attr 'barndoor1))) - (set-chan8 26 (percent->dmxval8 (get-attr 'barndoor2))) - (set-chan8 27 (percent->dmxval8 (get-attr 'barndoor3))) - (set-chan8 28 (percent->dmxval8 (get-attr 'barndoor4))) - - (set-chan8 7 (assv-ref '((#f . 0) - (red . 18) - (blue . 37) - (orange . 55) - (green . 73) - (amber . 91) - (uv . 110)) - (get-attr 'colwheel))) - - (set-chan8 15 (assv-ref '((#f . 0) - (iris . 5) - (gobo1 . 10) - (gobo2 . 14) - (gobo3 . 18) - (gobo4 . 22) - (gobo5 . 26) - (gobo6 . 30)) - (get-attr 'gobo))) - - (set-chan8 18 (assv-ref '((beam . 0) - (beamwash . 35) - (beamwashext . 45)) - (get-attr 'beamtype))) - - (let ((cmy (colour-as-cmy (get-attr 'colour)))) - (set-chan8 9 (percent->dmxval8 (car cmy))) - (set-chan8 10 (percent->dmxval8 (cadr cmy))) - (set-chan8 11 (percent->dmxval8 (caddr cmy))))) diff --git a/guile/starlet/fixture-library/stairville/octagon-theater-cw-ww.scm b/guile/starlet/fixture-library/stairville/octagon-theater-cw-ww.scm new file mode 100644 index 0000000..b3320b2 --- /dev/null +++ b/guile/starlet/fixture-library/stairville/octagon-theater-cw-ww.scm @@ -0,0 +1,51 @@ +;; +;; starlet/fixture-library/stairville/octagon-theater-cw-ww.scm +;; +;; Copyright © 2020-2022 Thomas White <taw@bitwiz.me.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 fixture-library stairville octagon-theater-cw-ww) + #:use-module (starlet scanout) + #:use-module (starlet fixture) + #:use-module (starlet attributes) + #:use-module (starlet utils) + #:export (<stairville-octagon-theater-cw-ww>)) + +(define-fixture + + <stairville-octagon-theater-cw-ww> + + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-continuous colour-temperature '(2800 6400) 3200) + (attr-list strobe '(#f #t) #f) + ;; FIXME: Strobe frequency is not stated in manual. + ;; I've assumed that "slow" means 1 Hz, "fast" 25 Hz + (attr-continuous strobe-frequency '(1 25) 1)) + + (let ((coltemp (get-attr colour-temperature))) + (set-chan8 1 (scale-and-clamp-to-range coltemp '(2800 6400) '(0 255))) + (set-chan8 2 (scale-and-clamp-to-range coltemp '(2800 6400) '(255 0)))) + (if (get-attr strobe) + (set-chan8 3 (scale-and-clamp-to-range + (get-attr strobe-frequency) + '(1 25) + '(16 255))) + (set-chan8 3 0)) + (set-chan8 3 0) ;; Strobe + (set-chan8 4 0) ;; Mode (0-15 = direct control) + (set-chan8 5 (percent->dmxval8 (get-attr intensity)))) diff --git a/guile/starlet/fixture-library/stairville/z120m.scm b/guile/starlet/fixture-library/stairville/z120m.scm new file mode 100644 index 0000000..00fb476 --- /dev/null +++ b/guile/starlet/fixture-library/stairville/z120m.scm @@ -0,0 +1,69 @@ +;; +;; starlet/fixture-library/stairville/z120m.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 fixture-library stairville z120m) + #:use-module (starlet scanout) + #:use-module (starlet fixture) + #:use-module (starlet attributes) + #:use-module (starlet utils) + #:use-module (starlet colours) + #:export (<stairville-z120m-6ch>)) + + +(define (colour-as-rgbw-weirdness col weirdness) + (let ((rgb (colour-as-rgb col))) + (let ((w (* (- 1 weirdness) (apply min rgb)))) + (list (- (red rgb) w) + (- (green rgb) w) + (- (blue rgb) w) + w)))) + + +(define-fixture + + <stairville-z120m-6ch> + + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-colour colour white) + (attr-continuous strobe-frequency '(1 25) 1) + (attr-list strobe '(off on random) 'off) + (attr-continuous white-weirdness '(0 100) 0)) + + (let ((intensity (get-attr intensity)) + (rgbw (colour-as-rgbw-weirdness (get-attr colour) + (/ (get-attr white-weirdness) 100)))) + (set-chan8 1 (percent->dmxval8 intensity)) + (set-chan8 3 (percent->dmxval8 (car rgbw))) + (set-chan8 4 (percent->dmxval8 (cadr rgbw))) + (set-chan8 5 (percent->dmxval8 (caddr rgbw))) + (set-chan8 6 (percent->dmxval8 (cadddr rgbw)))) + (cond + ((eq? (get-attr strobe) 'on) + (set-chan8 2 (scale-and-clamp-to-range + (get-attr 'strobe-frequency) + '(1 25) + '(106 165)))) + ((eq? (get-attr strobe) 'random) + (set-chan8 2 (scale-and-clamp-to-range + (get-attr strobe-frequency) + '(1 25) + '(181 240)))) + (else (set-chan8 2 255)))) diff --git a/guile/starlet/fixture-library/tadm/led-bar.scm b/guile/starlet/fixture-library/tadm/led-bar.scm new file mode 100644 index 0000000..45c4e34 --- /dev/null +++ b/guile/starlet/fixture-library/tadm/led-bar.scm @@ -0,0 +1,46 @@ +;; +;; starlet/fixture-library/tadm/led-bar.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 fixture-library tadm led-bar) + #:use-module (starlet scanout) + #:use-module (starlet fixture) + #:use-module (starlet attributes) + #:use-module (starlet colours) + #:use-module (starlet utils) + #:use-module (starlet attributes) + #:export (<tadm-led-bar>)) + +(define-fixture + + <tadm-led-bar> + + (fixture-attributes + (attr-continuous intensity '(0 100) 0) + (attr-colour colour white)) + + (let ((intensity (get-attr intensity)) + (rgb (colour-as-rgb (get-attr colour)))) + (set-chan8 1 17) + (set-chan8 2 (percent->dmxval8 intensity)) + (set-chan8 3 0) + (set-chan8 4 (percent->dmxval8 (car rgb))) + (set-chan8 5 (percent->dmxval8 (cadr rgb))) + (set-chan8 6 (percent->dmxval8 (caddr rgb))))) + diff --git a/guile/starlet/fixture.scm b/guile/starlet/fixture.scm index 9f58f25..524d78b 100644 --- a/guile/starlet/fixture.scm +++ b/guile/starlet/fixture.scm @@ -20,7 +20,10 @@ ;; (define-module (starlet fixture) #:use-module (starlet colours) + #:use-module (starlet utils) + #:use-module (starlet attributes) #:use-module (oop goops) + #:use-module (ice-9 exceptions) #:use-module (srfi srfi-1) #:export (<fixture> get-fixture-name @@ -28,23 +31,24 @@ get-fixture-universe get-fixture-attrs find-attr + fixture-has-attr? + fixture? scanout-fixture attr-continuous attr-list attr-colour + define-fixture + get-attr-type get-attr-range get-attr-home-val continuous-attribute? colour-attribute? - intensity? - scale-to-range - round-dmx - percent->dmxval8 - percent->dmxval16)) + next-attr-item + prev-attr-item)) (define-class <fixture-attribute> (<object>) @@ -66,7 +70,12 @@ (home-value #:init-value 0 #:init-keyword #:home-value - #:getter attr-home-value)) + #:getter attr-home-value) + + (comment + #:init-value "" + #:init-keyword #:comment + #:getter attr-comment)) (define-class <fixture> (<object>) @@ -87,23 +96,21 @@ #:getter get-fixture-addr #:setter set-fixture-addr!) - (friendly-name - #:init-value "Fixture" - #:init-keyword #:friendly-name - #:getter get-fixture-friendly-name - #:setter set-fixture-friendly-name!) - (scanout-func #:init-value (lambda (universe start-addr value set-dmx) #f) #:init-keyword #:scanout-func #:getter get-scanout-func)) -(define-generic scanout-fixture) - - (define-syntax attr-continuous (syntax-rules () + ((_ attr-name attr-range attr-home-value comment) + (make <fixture-attribute> + #:name attr-name + #:range attr-range + #:type 'continuous + #:home-value attr-home-value + #:comment comment)) ((_ attr-name attr-range attr-home-value) (make <fixture-attribute> #:name attr-name @@ -119,11 +126,24 @@ #:name attr-name #:range attr-allowed-values #:type 'list - #:home-value attr-home-value)))) + #:home-value attr-home-value)) + ((_ attr-name attr-allowed-values attr-home-value comment) + (make <fixture-attribute> + #:name attr-name + #:range attr-allowed-values + #:type 'list + #:home-value attr-home-value + #:comment comment)))) (define-syntax attr-colour (syntax-rules () + ((_ attr-name attr-home-value comment) + (make <fixture-attribute> + #:name attr-name + #:type 'colour + #:home-value attr-home-value + #:comment comment)) ((_ attr-name attr-home-value) (make <fixture-attribute> #:name attr-name @@ -131,6 +151,9 @@ #:home-value attr-home-value)))) +(define-generic scanout-fixture) + + (define (get-fixture-attrs fix) (slot-ref fix 'attributes)) @@ -139,34 +162,20 @@ (is-a? f <fixture>)) -(define-method (find-attr (fix <fixture>) (attr-name <symbol>)) +(define (find-attr fix attr-name) (find (lambda (a) (eq? (get-attr-name a) attr-name)) (get-fixture-attrs fix))) -(define-method (find-attr (fix <fixture>) (attr-name <colour-component-id>)) - (find-attr fix 'colour)) - - -(define-method (get-attr-home-val (fix <fixture>) (attr <symbol>)) +(define (get-attr-home-val fix attr) (let ((attr-obj (find-attr fix attr))) (if attr-obj (attr-home-value attr-obj) 'fixture-does-not-have-attribute))) -(define-method (get-attr-home-val (fix <fixture>) (attr <colour-component-id>)) - (extract-colour-component - (get-attr-home-val fix 'colour) - attr)) - - -(define (intensity? a) - (eq? 'intensity a)) - - (define (continuous-attribute? aobj) (eq? 'continuous (get-attr-type aobj))) @@ -177,28 +186,30 @@ (get-attr-type aobj))) -;; Helper functions for fixture scanout routines -(define (percent->dmxval8 val) - (round-dmx - (scale-to-range val '(0 100) '(0 255)))) - +(define-syntax define-fixture + (syntax-rules (fixture-attributes) -(define (percent->dmxval16 val) - (scale-to-range val '(0 100) '(0 65535))) + ((_ classname + (fixture-attributes attr ...) + scanout-code ...) + (begin + (define-class classname (<fixture>) + (attributes #:init-form (list attr ...))) + (define-method (scanout-fixture (fixture classname)) + scanout-code ...))))) -(define (round-dmx a) - (inexact->exact - (min 255 (max 0 (round a))))) +(define fixture-has-attr? find-attr) -(define (scale-to-range val orig-range dest-range) - (define (range r) - (- (cadr r) (car r))) +(define (next-attr-item attr cval) + (next-item-in-list + (get-attr-range attr) + cval)) - (+ (car dest-range) - (* (range dest-range) - (/ (- val (car orig-range)) - (range orig-range))))) +(define (prev-attr-item attr cval) + (next-item-in-list + (reverse (get-attr-range attr)) + cval)) diff --git a/guile/starlet/midi-control/base.scm b/guile/starlet/midi-control/base.scm deleted file mode 100644 index 9363e81..0000000 --- a/guile/starlet/midi-control/base.scm +++ /dev/null @@ -1,273 +0,0 @@ -;; -;; starlet/midi-control/base.scm -;; -;; Copyright © 2020-2021 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 midi-control base) - #:use-module (oop goops) - #:use-module (ice-9 atomic) - #:use-module (ice-9 threads) - #:use-module (ice-9 exceptions) - #:use-module (ice-9 binary-ports) - #:use-module (srfi srfi-1) - #:export (make-midi-controller - get-cc-value - ccval->percent - percent->ccval - send-note-on - send-note-off - register-midi-note-callback! - register-midi-cc-callback! - remove-midi-callback! - get-parameter-controller - set-parameter-controller!)) - - -(define-class <midi-control-surface> (<object>) - (cc-values - #:init-form (make-vector 128 #f) - #:getter get-cc-values) - - (channel - #:init-form (error "MIDI channel must be specified for controller") - #:init-keyword #:channel - #:getter get-channel) - - (callbacks - #:init-form (make-atomic-box '()) - #:getter get-callbacks) - - (send-queue - #:init-form (make-atomic-box '()) - #:getter get-send-queue) - - (parameter-controller - #:init-value #f - #:getter get-parameter-controller - #:setter set-parameter-controller!)) - - -(define-class <midi-callback> (<object>) - (type - #:init-keyword #:type - #:getter get-type) - - (note-or-cc-number - #:init-keyword #:note-or-cc-number - #:getter get-note-or-cc-number) - - (callback - #:init-keyword #:func - #:getter get-callback-func)) - - -(define (find-cc-callbacks controller cc-number) - (filter (lambda (a) - (and (eq? cc-number (get-note-or-cc-number a)) - (eq? 'cc (get-type a)))) - (atomic-box-ref (get-callbacks controller)))) - - -(define (find-note-callbacks controller note-number) - (filter (lambda (a) - (and (eq? note-number (get-note-or-cc-number a)) - (eq? 'note (get-type a)))) - (atomic-box-ref (get-callbacks controller)))) - - -(define (remove-midi-callback! controller callback) - (when controller - (atomic-box-set! (get-callbacks controller) - (delq callback - (atomic-box-ref (get-callbacks controller)))))) - - -(define (register-midi-callback! controller - type - note-or-cc-number - func) - (let ((new-callback (make <midi-callback> - #:type type - #:note-or-cc-number note-or-cc-number - #:func func))) - (let ((callback-list-box (get-callbacks controller))) - (atomic-box-set! callback-list-box - (cons new-callback - (atomic-box-ref callback-list-box)))) - new-callback)) - - -(define* (register-midi-note-callback! - controller - #:key (note-number 1) (func #f) (unique #t)) - (when controller - (when unique - (for-each (lambda (callback) - (remove-midi-callback! controller callback)) - (find-note-callbacks - controller - note-number))) - (register-midi-callback! controller 'note note-number func))) - - -(define* (register-midi-cc-callback! - controller - #:key (cc-number 1) (func #f) (unique #t)) - (when controller - (when unique - (for-each (lambda (callback) - (remove-midi-callback! controller callback)) - (find-cc-callbacks - controller - cc-number))) - (register-midi-callback! controller 'cc cc-number func))) - - -(define enqueue-midi-bytes! - (lambda (controller . bytes) - (let* ((send-queue (get-send-queue controller)) - (old-queue (atomic-box-ref send-queue)) - (new-queue (append old-queue bytes))) - (unless (eq? (atomic-box-compare-and-swap! send-queue - old-queue - new-queue) - old-queue) - (apply enqueue-midi-bytes! (cons controller bytes)))))) - - -(define* (send-note-on controller note) - (when (and controller note) - (enqueue-midi-bytes! controller - (+ #b10010000 (get-channel controller)) - note - 127))) - - -(define* (send-note-off controller note) - (when (and controller note) - (enqueue-midi-bytes! controller - (+ #b10000000 (get-channel controller)) - note - 0))) - - -(define (all-notes-off! controller) - (for-each (lambda (l) - (enqueue-midi-bytes! controller - (+ #b10000000 (get-channel controller)) - l - 0)) - (iota 128))) - - -(define (check-cc-callbacks controller cc-number old-val new-val) - (for-each (lambda (a) ((get-callback-func a) old-val new-val)) - (find-cc-callbacks controller cc-number))) - - -(define (handle-cc-change! controller cc-number value) - (let* ((ccvals (get-cc-values controller)) - (old-value (vector-ref ccvals cc-number))) - (vector-set! ccvals cc-number value) - (check-cc-callbacks controller cc-number old-value value))) - - -(define* (get-cc-value controller cc-number) - (if controller - (vector-ref (get-cc-values controller) cc-number) - #f)) - - -(define (check-note-callbacks controller note-number) - (for-each (lambda (a) ((get-callback-func a))) - (find-note-callbacks controller note-number))) - - -(define (ccval->percent n) - (/ (* n 100) 127)) - - -(define (percent->ccval n) - (inexact->exact (round (/ (* n 127) 100)))) - - -(define (make-midi-controller-real device-name channel) - (let ((controller (make <midi-control-surface> - #:channel channel))) - (let ((midi-port (open-file device-name "r+0b"))) - - ;; Read thread - (begin-thread - (with-exception-handler - (lambda (exn) - (backtrace) - (raise-exception exn)) - (lambda () - (let again () - - (let* ((status-byte (get-u8 midi-port)) - (channel (bit-extract status-byte 0 4)) - (command (bit-extract status-byte 4 8))) - - (case command - - ;; Note on - ((9) (let* ((note (get-u8 midi-port)) - (vel (get-u8 midi-port))) - (check-note-callbacks controller note))) - - ;; Control value - ((11) (let* ((cc-number (get-u8 midi-port)) - (value (get-u8 midi-port))) - (handle-cc-change! controller - cc-number - value)))) - - (yield) - (again)))))) - - ;; Write thread - (begin-thread - (let again () - (let ((bytes-to-send - (atomic-box-swap! - (get-send-queue controller) - '()))) - (for-each (lambda (a) - (put-u8 midi-port a) - (usleep 1)) - bytes-to-send) - (usleep 1000) - (again)))) - - (all-notes-off! controller) - controller))) - - -(define* (make-midi-controller device-name channel) - (with-exception-handler - - (lambda (exn) - (format #t "Couldn't start MIDI ~a\n" - (exception-irritants exn)) - #f) - - (lambda () - (make-midi-controller-real device-name channel)) - - #:unwind? #t)) diff --git a/guile/starlet/midi-control/button-utils.scm b/guile/starlet/midi-control/button-utils.scm deleted file mode 100644 index 8462e3e..0000000 --- a/guile/starlet/midi-control/button-utils.scm +++ /dev/null @@ -1,93 +0,0 @@ -;; -;; starlet/midi-control/button-utils.scm -;; -;; Copyright © 2020-2021 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 midi-control button-utils) - #:use-module (starlet midi-control base) - #:use-module (starlet state) - #:use-module (starlet playback) - #:export (make-go-button - make-stop-button - make-back-button - select-on-button)) - - -(define* (make-go-button controller pb button - #:key - (ready-note #f) - (pause-note #f)) - (register-midi-note-callback! - controller - #:note-number button - #:func (lambda () (go! pb))) - - (when (or ready-note pause-note) - (add-hook! - (state-change-hook pb) - (lambda (new-state) - (cond - ((eq? new-state 'pause) - (send-note-on controller pause-note)) - ((eq? new-state 'ready) - (send-note-on controller ready-note)) - ((eq? new-state 'running) - (send-note-on controller ready-note)) - (else - (send-note-off controller ready-note))))))) - - -(define* (make-stop-button controller pb button - #:key - (ready-note #f)) - (register-midi-note-callback! - controller - #:note-number button - #:func (lambda () (stop! pb))) - - (when ready-note - (add-hook! - (state-change-hook pb) - (lambda (new-state) - (if (eq? new-state 'running) - (send-note-on controller ready-note) - (send-note-off controller ready-note)))))) - - -(define* (make-back-button controller pb button - #:key - (ready-note #f)) - (register-midi-note-callback! - controller - #:note-number button - #:func (lambda () (back! pb))) - - (when ready-note - (send-note-on controller ready-note))) - - -(define* (select-on-button controller button fixture - #:key - (ready-note #f)) - (register-midi-note-callback! - controller - #:note-number button - #:func (lambda () (sel fixture))) - - (when ready-note - (send-note-on controller ready-note))) diff --git a/guile/starlet/midi-control/faders.scm b/guile/starlet/midi-control/faders.scm deleted file mode 100644 index bd2da95..0000000 --- a/guile/starlet/midi-control/faders.scm +++ /dev/null @@ -1,348 +0,0 @@ -;; -;; starlet/midi-control/faders.scm -;; -;; Copyright © 2020-2021 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 midi-control faders) - #:use-module (starlet midi-control base) - #:use-module (starlet state) - #:use-module (starlet fixture) - #:use-module (starlet colours) - #:use-module (starlet scanout) - #:use-module (starlet utils) - #:use-module (srfi srfi-1) - #:use-module (oop goops) - #:export (set-midi-control-map! - state-on-fader)) - - -(define-class <parameter-controller> (<object>) - (callbacks - #:init-keyword #:callbacks - #:getter get-callbacks - #:setter set-callbacks!) - - (control-map - #:init-keyword #:control-map - #:getter get-control-map)) - - -(define (name-for-fader-state controller cc-number) - (call-with-output-string - (lambda (port) - (format port "faderstate-~a-cc~a" - controller - cc-number)))) - - -(define* (state-on-fader controller - cc-number - state) - (register-state! - (lighting-state - (state-for-each - (lambda (fix attr val) - (at fix attr - (lambda () - - (let ((cc-val (get-cc-value controller cc-number))) - - ;; Fader position known? - (if cc-val - - (if (intensity? attr) - - ;; Intensity parameters get scaled according to the fader - (* 0.01 val (ccval->percent cc-val)) - - ;; Non-intensity parameters just get set in our new state, - ;; but only if the fader is up! - (if (> cc-val 0) - val - 'no-value)) - - ;; Fader position unknown - 'no-value))))) - - state)) - #:unique-name (name-for-fader-state controller cc-number))) - - -(define (current-values fixture-list attr-name) - (map (lambda (fix) - (current-value fix attr-name)) - fixture-list)) - - -(define (fixtures-with-attr fixture-list attr-name) - (let ((attrs (map (partial find-attr attr-name) fixture-list))) - (fold (lambda (fix attr old) - (if attr - (cons (cons fix (car old)) - (cons attr (cdr old))) - old)) - (cons '() '()) - fixture-list attrs))) - - -(define (clamp-to-attr-range attr-obj val) - (let ((r (get-attr-range-maybe-colour attr-obj))) - (max (car r) - (min (cadr r) - val)))) - - -(define* (at-midi-jogwheel controller - fixture-list - attr - cc-number - #:key (led #f)) - - (define (ccval->offset a) - (if (eq? a 127) - -1 - 1)) - - (let ((fixtures (car (fixtures-with-attr fixture-list attr)))) - (unless (null? fixtures) - - (when led - (send-note-on controller led)) - - (let ((old-vals (current-values fixtures attr)) - (offset 0)) - (register-midi-cc-callback! - controller - #:cc-number cc-number - #:func (lambda (prev-cc-val new-cc-value) - (set! offset (+ offset (ccval->offset new-cc-value))) - (for-each (lambda (fix old-val) - (let ((attr-obj (find-attr fix attr))) - (when (and attr-obj - (continuous-attribute? attr-obj)) - (set-in-state! programmer-state - fix - attr - (clamp-to-attr-range - attr-obj - (+ old-val offset)) - controller)))) - fixtures old-vals))))))) - - -(define (get-attr-range-maybe-colour attr-obj) - (if (colour-attribute? attr-obj) - '(0 100) - (get-attr-range attr-obj))) - - -(define (fader-congruent vals attrs) - (mean (map (lambda (val attr) - (scale-to-range val - (get-attr-range-maybe-colour attr) - '(0 127))) - vals attrs))) - - -(define (fader-up-gradients initial-vals - attrs - congruent-val) - (map (lambda (initial-val attr) - (let ((attr-max (cadr (get-attr-range-maybe-colour attr)))) - (if (< congruent-val 127) - (/ (- attr-max initial-val) - (- 127 congruent-val)) - 0))) - initial-vals - attrs)) - - -(define (fader-down-gradients initial-vals - attrs - congruent-val) - (map (lambda (initial-val attr) - (let ((attr-min (car (get-attr-range-maybe-colour attr)))) - (if (> congruent-val 0) - (/ (- initial-val attr-min) - congruent-val) - 0))) - - initial-vals - attrs)) - - -(define (apply-fader cc-offset - attr-name - gradients - initial-vals - fixtures - controller) - (for-each (lambda (fix initial-val gradient) - (set-in-state! programmer-state - fix - attr-name - (+ initial-val - (* gradient cc-offset)) - controller)) - fixtures - initial-vals - gradients)) - - -(define* (at-midi-fader controller - fixture-list - attr-name - cc-number - #:key - (led-incongruent #f) - (led #f)) - - (let ((fixtures-attrs (fixtures-with-attr fixture-list attr-name))) - (unless (null? (car fixtures-attrs)) - (let* ((fixtures (car fixtures-attrs)) - (attrs (cdr fixtures-attrs)) - (initial-vals (current-values fixtures attr-name)) - (congruent-val (fader-congruent initial-vals attrs)) - (up-gradients (fader-up-gradients initial-vals attrs congruent-val)) - (dn-gradients (fader-down-gradients initial-vals attrs congruent-val)) - (cc-val (get-cc-value controller cc-number)) - (congruent (and cc-val (= cc-val congruent-val)))) - - (if congruent - (send-note-on controller led) - (send-note-on controller led-incongruent)) - - (register-midi-cc-callback! - controller - #:cc-number cc-number - #:func (lambda (prev-cc-val new-cc-value) - - (if congruent - - (cond - ((> new-cc-value congruent-val) - (apply-fader (- new-cc-value congruent-val) - attr-name - up-gradients - initial-vals - fixtures - controller)) - ((<= new-cc-value congruent-val) - (apply-fader (- new-cc-value congruent-val) - attr-name - dn-gradients - initial-vals - fixtures - controller))) - - (when (or (and (not prev-cc-val) - (= new-cc-value congruent-val)) - (and prev-cc-val new-cc-value - (in-range congruent-val - prev-cc-val - new-cc-value))) - (set! congruent #t) - (send-note-on controller led))))))))) - - -(define (midi-control-attr controller control-spec fixture-list) - (cond - - ((eq? 'jogwheel (cadr control-spec)) - (at-midi-jogwheel controller - fixture-list - (car control-spec) - (caddr control-spec) - #:led (cadddr control-spec))) - - ((eq? 'fader (cadr control-spec)) - (at-midi-fader controller - fixture-list - (car control-spec) - (caddr control-spec) - #:led (car (cadddr control-spec)) - #:led-incongruent (cadr (cadddr control-spec)))))) - - -(define (led-off controller leds) - (cond - ((list? leds) - (for-each (lambda (note) - (send-note-off controller note)) - leds)) - ((number? leds) - (send-note-off controller leds)))) - - -(define (scrub-parameter-controller! controller parameter-controller) - - ;; Remove all the old callbacks - (for-each (lambda (callback) - (remove-midi-callback! controller callback)) - (get-callbacks parameter-controller)) - - ;; Switch off all the old LEDs - (for-each (lambda (control-spec) - (led-off controller (cadddr control-spec))) - (get-control-map parameter-controller))) - - -(define (update-midi-controls controller fixture-list) - - (scrub-parameter-controller! controller - (get-parameter-controller controller)) - - (set-callbacks! - (get-parameter-controller controller) - (map (lambda (control-spec) - (midi-control-attr controller control-spec fixture-list)) - (get-control-map (get-parameter-controller controller))))) - - -(define (set-midi-control-map! controller new-control-map) - (let ((old-parameter-controller (get-parameter-controller controller))) - - ;; Remove the old parameter controller - (when old-parameter-controller - (scrub-parameter-controller! controller old-parameter-controller)) - - (set-parameter-controller! - controller - (make <parameter-controller> - #:callbacks '() - #:control-map new-control-map)) - - ;; If this is the first time, add the callbacks - (unless old-parameter-controller - - ;; Selection changed - (add-hook! - selection-hook - (lambda (fixture-list) - (update-midi-controls controller fixture-list))) - - ;; Value changed - (add-update-hook! programmer-state - (lambda (fix attr value source) - (unless (eq? source controller) - (update-midi-controls controller (get-selection)))))) - - ;; If there is a selection, run the callback now - (let ((current-selection (get-selection))) - (when current-selection - (update-midi-controls controller current-selection))))) diff --git a/guile/starlet/open-sound-control/utils.scm b/guile/starlet/open-sound-control/utils.scm new file mode 100644 index 0000000..567c2b3 --- /dev/null +++ b/guile/starlet/open-sound-control/utils.scm @@ -0,0 +1,467 @@ +;; +;; starlet/open-sound-control/utils.scm +;; +;; Copyright © 2020-2023 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 open-sound-control utils) + #:use-module (starlet attributes) + #:use-module (starlet playback) + #:use-module (starlet selection) + #:use-module (starlet fixture) + #:use-module (starlet engine) + #:use-module (starlet state) + #:use-module (starlet utils) + #:use-module (starlet colours) + #:use-module (open-sound-control client) + #:use-module (open-sound-control server-thread) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (ice-9 receive) + #:export (osc-playback-controls + osc-select-button + osc-parameter-encoder + osc-smart-potentiometer + osc-cmy-potentiometer + osc-state-fader + send-selection-updates-to)) + + +(define* (osc-playback-controls pb server addr go-button stop-button back-button + #:key (min-time-between-presses 0.2)) + + (let ((time-last-press 0)) + (add-osc-method + server + (string-append go-button "/press") + "" + (lambda () + (let ((time-this-press (hirestime))) + (if (> time-this-press (+ time-last-press min-time-between-presses)) + (go! pb) + (display "Too soon after last press!\n")) + (set! time-last-press time-this-press))))) + + (add-osc-method server (string-append stop-button "/press") "" (lambda () (stop! pb))) + (add-osc-method server (string-append back-button "/press") "" (lambda () (back! pb))) + + ;; LEDs + (osc-send addr (string-append back-button "/set-led") 'green) + + (add-and-run-hook! + (state-change-hook pb) + (lambda (new-state) + + (if (eq? new-state 'running) + (osc-send addr (string-append stop-button "/set-led") 'green) + (osc-send addr (string-append stop-button "/set-led") 'off)) + + (cond + ((eq? new-state 'pause) + (osc-send addr (string-append go-button "/set-led") 'orange)) + ((eq? new-state 'ready) + (osc-send addr (string-append go-button "/set-led") 'green)) + ((eq? new-state 'running) + (osc-send addr (string-append go-button "/set-led") 'green)) + (else + (osc-send addr (string-append go-button "/set-led") 'off)))) + + (playback-state pb))) + + +(define (osc-select-button fix server addr button) + + (add-osc-method + server + (string-append button "/press") + "" + (lambda () + (toggle-sel fix))) + + (add-and-run-hook! + selection-hook + (lambda (sel) + (if (selected? fix) + (osc-send addr (string-append button "/set-led") 'orange) + (osc-send addr (string-append button "/set-led") 'red))) + (get-selection))) + + +(define (encoder-inc attr-id n) + (for-each + (lambda (fix) + (let ((attr (find-attr fix attr-id)) + (cval (current-value fix attr-id))) + (cond + ((eq? 'continuous (get-attr-type attr)) + (at fix attr-id (+ cval n))) + ((eq? 'list (get-attr-type attr)) + (if (> n 0) + (at fix attr-id (next-attr-item attr cval)) + (at fix attr-id (prev-attr-item attr cval))))))) + (get-selection))) + + +(define (osc-parameter-encoder attr server addr encoder) + + (add-osc-method server (string-append encoder "/inc") "" + (lambda () (encoder-inc attr 3))) + + (add-osc-method server (string-append encoder "/dec") "" + (lambda () (encoder-inc attr -3))) + + (add-osc-method server (string-append encoder "/inc-fine") "" + (lambda () (encoder-inc attr 1))) + + (add-osc-method server (string-append encoder "/dec-fine") "" + (lambda () (encoder-inc attr -1))) + + (add-and-run-hook! + selection-hook + (lambda (sel) + (if (any + (lambda (fix) + (fixture-has-attr? fix attr)) + (get-selection)) + (osc-send addr (string-append encoder "/set-led") 'green) + (osc-send addr (string-append encoder "/set-led") 'off))) + (get-selection))) + + +(define (ccval->percent n) + (/ (* n 100) 127)) + + +(define (osc-state-fader server addr fader state) + (let ((fader-val 0)) + (register-state! + (lighting-state + (state-for-each + (lambda (fix attr val) + (at fix attr + (lambda () + + (if (intensity? attr) + + ;; Intensity parameters get scaled according to the fader + (* 0.01 val (ccval->percent fader-val)) + + ;; Non-intensity parameters just get set in our new state, + ;; but only if the fader is up! + (if (> fader-val 0) + val + 'no-value))))) + state))) + + (osc-send addr (string-append fader "/enable")) + (osc-send addr (string-append fader "/set-pickup") 0) + (add-osc-method server (string-append fader "/value-change") "i" + (lambda (v) (set! fader-val v))))) + + +(define (send-selection-updates-to addr) + (add-hook! + selection-hook + (lambda (sel) + (osc-send + addr + "/starlet/selection/update" + (get-selection-as-string))))) + + +(define (fader-up-gradients initial-vals + max-vals + congruent-val) + (map (lambda (initial-val attr-max) + (if (< congruent-val 127) + (/ (- attr-max initial-val) + (- 127 congruent-val)) + 0)) + initial-vals + max-vals)) + + +(define (fader-down-gradients initial-vals + min-vals + congruent-val) + (map (lambda (initial-val attr-min) + (if (> congruent-val 0) + (/ (- initial-val attr-min) + congruent-val) + 0)) + initial-vals + min-vals)) + + +(define (fixtures-with-attr fixture-list attr-name) + (let ((fix-attrs + (map (lambda (fix) + (let ((attr (find-attr fix attr-name))) + (if attr + (cons fix attr) + (cons #f #f)))) + fixture-list))) + (values + (filter (lambda (x) x) (map car fix-attrs)) + (filter (lambda (x) x) (map cdr fix-attrs))))) + + +(define (current-values fixture-list attr-name) + (map (lambda (fix) + (current-value fix attr-name)) + fixture-list)) + + +(define-record-type <smart-potentiometer> + (smart-pot-record addr + pot-method + initial-vals + min-vals + max-vals + congruent-val + up-gradients + dn-gradients) + smart-pot? + (addr get-target-addr) + (pot-method get-method) + (initial-vals get-initial-vals set-initial-vals) + (min-vals get-min-vals set-min-vals) + (max-vals get-max-vals set-max-vals) + (congruent-val get-congruent-val set-congruent-val) + (up-gradients get-up-gradients set-up-gradients) + (dn-gradients get-dn-gradients set-dn-gradients)) + + +(define (make-smart-potentiometer server addr pot-method callback) + + (let ((sp (smart-pot-record addr pot-method '() '() '() 0 '() '()))) + + (add-osc-method + server + (string-append pot-method "/value-change") + "i" + (lambda (new-cc-value) + (callback + (map + (lambda (initial-val gradient) + (+ initial-val + (* gradient + (- new-cc-value (get-congruent-val sp))))) + (get-initial-vals sp) + (if (> new-cc-value (get-congruent-val sp)) + (get-up-gradients sp) + (get-dn-gradients sp)))))) + + sp)) + + +(define (reset-gradients sp) + (unless (nil? (get-initial-vals sp)) + (set-congruent-val sp + (mean + (map + (lambda (val min-val max-val) + (scale-to-range val (list min-val max-val) '(0 127))) + (get-initial-vals sp) + (get-min-vals sp) + (get-max-vals sp)))) + (set-up-gradients sp + (fader-up-gradients + (get-initial-vals sp) + (get-max-vals sp) + (get-congruent-val sp))) + (set-dn-gradients sp + (fader-up-gradients + (get-initial-vals sp) + (get-min-vals sp) + (get-congruent-val sp))) + (osc-send + (get-target-addr sp) + (string-append (get-method sp) "/set-pickup") + (get-congruent-val sp)))) + + +(define (osc-smart-potentiometer attr-name + server + addr + potentiometer) + + (let ((fixtures '())) + + ;; First, create a smart potentiometer object and tell it to + ;; set the attribute values in the programmer state + (let ((smart-pot + (make-smart-potentiometer + server + addr + potentiometer + (lambda (new-vals) + (for-each + (lambda (fix new-val) + (set-in-state! programmer-state + fix + attr-name + new-val + potentiometer)) + fixtures new-vals))))) + + ;; Next, set up a selection hook callback to update the list of + ;; fixtures we are controlling + (add-and-run-hook! + selection-hook + (lambda (selection) + (receive + (new-fixtures attrs) + (fixtures-with-attr selection attr-name) + (if (nil? new-fixtures) + (osc-send addr (string-append potentiometer "/disable")) + (begin + (set! fixtures new-fixtures) + (let ((ranges (map get-attr-range attrs))) + (set-min-vals smart-pot (map first ranges)) + (set-max-vals smart-pot (map second ranges))) + (set-initial-vals smart-pot (current-values fixtures attr-name)) + (reset-gradients smart-pot) + (osc-send addr (string-append potentiometer "/enable")))))) + (get-selection)) + + ;; Finally, arrange for the smart potentiometer object to be notified + ;; if the values change externally + (add-update-hook! + programmer-state + (lambda (source) + (unless (eq? source potentiometer) + (set-initial-vals smart-pot (current-values fixtures attr-name)) + (reset-gradients smart-pot))))))) + + +(define (osc-cmy-potentiometer attr-name server addr c-pot-method m-pot-method y-pot-method) + + (let ((fixtures '()) + (colours '())) + + (let ((c-pot + (make-smart-potentiometer + server + addr + c-pot-method + (lambda (new-vals) + (set! colours + (map + (lambda (old-colour new-c) + (cmy new-c + (magenta old-colour) + (yellow old-colour))) + (map colour-as-cmy colours) new-vals)) + (for-each + (lambda (fix colour) + (set-in-state! programmer-state + fix + attr-name + colour + c-pot-method)) + fixtures colours)))) + + (m-pot + (make-smart-potentiometer + server + addr + m-pot-method + (lambda (new-vals) + (set! colours + (map + (lambda (old-colour new-m) + (cmy (cyan old-colour) + new-m + (yellow old-colour))) + (map colour-as-cmy colours) new-vals)) + (for-each + (lambda (fix colour) + (set-in-state! programmer-state + fix + attr-name + colour + m-pot-method)) + fixtures colours)))) + + (y-pot + (make-smart-potentiometer + server + addr + y-pot-method + (lambda (new-vals) + (set! colours + (map + (lambda (old-colour new-y) + (cmy (cyan old-colour) + (magenta old-colour) + new-y)) + (map colour-as-cmy colours) new-vals)) + (for-each + (lambda (fix colour) + (set-in-state! programmer-state + fix + attr-name + colour + y-pot-method)) + fixtures colours))))) + + (add-and-run-hook! + selection-hook + (lambda (selection) + (receive + (new-fixtures attrs) + (fixtures-with-attr selection attr-name) + (if (nil? new-fixtures) + (begin + (osc-send addr (string-append c-pot-method "/disable")) + (osc-send addr (string-append m-pot-method "/disable")) + (osc-send addr (string-append y-pot-method "/disable"))) + (begin + (set! fixtures new-fixtures) + (set-min-vals c-pot (map (lambda (x) 0) fixtures)) + (set-min-vals m-pot (map (lambda (x) 0) fixtures)) + (set-min-vals y-pot (map (lambda (x) 0) fixtures)) + (set-max-vals c-pot (map (lambda (x) 100) fixtures)) + (set-max-vals m-pot (map (lambda (x) 100) fixtures)) + (set-max-vals y-pot (map (lambda (x) 100) fixtures)) + (set! colours (current-values fixtures attr-name)) + (set-initial-vals c-pot (map cyan (map colour-as-cmy colours))) + (set-initial-vals m-pot (map magenta (map colour-as-cmy colours))) + (set-initial-vals y-pot (map yellow (map colour-as-cmy colours))) + (reset-gradients c-pot) + (reset-gradients m-pot) + (reset-gradients y-pot) + (osc-send addr (string-append c-pot-method "/enable")) + (osc-send addr (string-append m-pot-method "/enable")) + (osc-send addr (string-append y-pot-method "/enable")))))) + (get-selection)) + + (add-update-hook! + programmer-state + (lambda (source) + (unless (or (eq? source c-pot-method) + (eq? source m-pot-method) + (eq? source y-pot-method)) + (set! colours (current-values fixtures attr-name)) + (set-initial-vals c-pot (map cyan (map colour-as-cmy colours))) + (set-initial-vals m-pot (map magenta (map colour-as-cmy colours))) + (set-initial-vals y-pot (map yellow (map colour-as-cmy colours))) + (reset-gradients c-pot) + (reset-gradients m-pot) + (reset-gradients y-pot))))))) diff --git a/guile/starlet/playback.scm b/guile/starlet/playback.scm index f9baca7..423abd2 100644 --- a/guile/starlet/playback.scm +++ b/guile/starlet/playback.scm @@ -26,16 +26,18 @@ #: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 scanout) + #:use-module (starlet engine) #:use-module (starlet utils) #:use-module (starlet clock) + #:use-module (starlet cue-list) + #:use-module (starlet cue-part) #:use-module (starlet colours) + #:use-module (starlet attributes) #:export (make-playback - cue - cue-part cut-to-cue-number! get-playback-cue-number run-cue-number! @@ -43,10 +45,10 @@ cut! stop! back! - cue-list reload-cue-list! - print-playback - state-change-hook)) + reassert-current-cue! + state-change-hook + playback-state)) ;; A "playback" is a state which knows how to run cues @@ -62,6 +64,10 @@ #:getter get-playback-cue-list-file #:setter set-playback-cue-list-file!) + (recovery-file + #:init-keyword #:recovery-file + #:getter get-playback-recovery-file) + (next-cue-index #:init-value 0 #:getter get-next-cue-index @@ -69,8 +75,8 @@ (running-cue-clock #:init-value #f - #:getter get-cue-clock - #:setter set-cue-clock!) + #:getter get-pb-cue-clock + #:setter set-pb-cue-clock!) (running-cue #:init-value #f @@ -86,65 +92,12 @@ #:getter state-change-hook)) -(define-record-type <cue-part> - (make-cue-part attr-list - fade-times) - cue-part? - (attr-list get-cue-part-attr-list) - (fade-times get-cue-part-fade-times)) - - -(define-record-type <fade-times> - (make-fade-times up-time - down-time - attr-time - up-delay - down-delay - attr-delay) - fade-times? - (up-time get-fade-up-time) - (down-time get-fade-down-time) - (attr-time get-fade-attr-time) - (up-delay get-fade-up-delay) - (down-delay get-fade-down-delay) - (attr-delay get-fade-attr-delay)) - - -(define-record-type <cue> - (make-cue number - state - tracked-state - preset-state - fade-times - preset-time - track-intensities - cue-parts) - cue? - (number get-cue-number) - (state get-cue-state) - (tracked-state get-tracked-state - set-tracked-state!) - (preset-state get-preset-state - set-preset-state!) - (fade-times get-cue-fade-times) - (preset-time get-cue-preset-time) - (track-intensities track-intensities) - (cue-parts get-cue-parts)) - - (define (get-playback-cue-number pb) - (cue-index-to-number (get-playback-cue-list pb) - (max 0 (- (get-next-cue-index pb) 1)))) - -(define (qnum a) - (/ (inexact->exact (* a 1000)) 1000)) - - -(define (read-cue-list-file filename) - (call-with-input-file - filename - (lambda (port) - (eval (read port) (interaction-environment))))) + (let ((cue-idx (get-next-cue-index pb))) + (if cue-idx + (cue-index-to-number (get-playback-cue-list pb) + (max 0 (- cue-idx 1))) + #f))) (define (reload-cue-list! pb) @@ -169,29 +122,52 @@ 'playback-without-cue-list-file))) +(define (read-recovery-file! pb) + (with-exception-handler + (lambda (exn) + (display "Failed to read recovery file - going to cue zero\n") + (cut-to-cue-index! pb 0)) + (lambda () + (call-with-input-file + (get-playback-recovery-file pb) + (lambda (port) + (let ((val (read port))) + (if (number? val) + (cut-to-cue-number! pb val) + (cut-to-cue-index! pb 0)))))) + #:unwind? #t)) + + +(define (write-recovery-file! pb the-cue-number) + (with-exception-handler + (lambda (exn) + (display "Failed to write recovery file (just FYI)\n") + (display exn)) + (lambda () + (call-with-output-file + (get-playback-recovery-file pb) + (lambda (port) + (write (qnum the-cue-number) port)))) + #:unwind? #t)) + + (define* (make-playback #:key (cue-list-file #f) - (cue-list #f)) + (cue-list #f) + (recovery-file #f)) (let ((new-playback (make <starlet-playback> #:cue-list (if cue-list-file (read-cue-list-file cue-list-file) cue-list) - #:cue-list-file cue-list-file))) + #:cue-list-file cue-list-file + #:recovery-file recovery-file))) (register-state! new-playback) + (if recovery-file + (read-recovery-file! new-playback) + (cut-to-cue-index! new-playback 0)) new-playback)) -(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 (set-playback-state! pb state) (atomic-box-set! (state-box pb) state) (run-hook (state-change-hook pb) state)) @@ -200,23 +176,28 @@ (define (cut-to-cue-index! pb cue-index) (clear-state! pb) (set-next-cue-index! pb (+ cue-index 1)) - (set-cue-clock! pb #f) + (set-pb-cue-clock! pb #f) (set-running-cue! pb #f) (set-playback-state! pb 'ready) - ;; Set the actual state - (state-for-each - (lambda (fix attr val) - (set-in-state! pb fix attr (lambda () val))) - (get-tracked-state (vector-ref (get-playback-cue-list pb) - cue-index))) + (let ((the-cue (vector-ref (get-playback-cue-list pb) + cue-index))) + ;; Set the actual state + (for-each + (lambda (part) + (state-for-each + (lambda (fix attr val) + (set-in-state! pb fix attr (lambda () val))) + (get-cue-part-state part))) + (get-cue-parts the-cue)) - ;; Set the preset state on top - (state-for-each - (lambda (fix attr val) - (set-in-state! pb fix attr (lambda () val))) - (get-preset-state (vector-ref (get-playback-cue-list pb) - cue-index)))) + ;; Set the preset state on top + (state-for-each + (lambda (fix attr val) + (set-in-state! pb fix attr (lambda () val))) + (get-preset-state the-cue)) + + (write-recovery-file! pb (get-cue-number the-cue)))) (define (cut-to-cue-number! pb cue-number) @@ -254,7 +235,7 @@ (define (go! pb) - (let ((clock (get-cue-clock pb))) + (let ((clock (get-pb-cue-clock pb))) (if (and clock (clock-stopped? clock)) @@ -277,14 +258,19 @@ (define (cut! pb) - (cut-to-cue-index! pb (get-next-cue-index pb))) + (let ((nci (get-next-cue-index pb))) + (if nci + (if (< nci (vector-length (get-playback-cue-list pb))) + (cut-to-cue-index! pb (get-next-cue-index pb)) + 'no-more-cues-in-list) + 'next-cue-unspecified))) (define (stop! pb) - (let ((clock (get-cue-clock pb))) + (let ((clock (get-pb-cue-clock pb))) (when (and clock (not (clock-expired? clock))) - (stop-clock! (get-cue-clock pb)) + (stop-clock! (get-pb-cue-clock pb)) (set-playback-state! pb 'pause)))) @@ -298,436 +284,113 @@ 'next-cue-unspecified)) -(define (snap-fade start-val - target-val - clock) - (if (> (elapsed-fraction clock) 0) - target-val - start-val)) - - -(define (colour-fade start-val - end-val - clock) - - (unless (and (colour? start-val) - (colour? end-val)) - (raise-exception (make-exception - (make-exception-with-message - "Non-colour arguments given to colour-fade") - (make-exception-with-irritants - (list start-val end-val))))) - - (interpolate-colour start-val - end-val - (elapsed-fraction clock) - #:interpolation-type 'linear-cmy)) - - -(define (simple-fade start-val - end-val - clock) - - (unless (and (number? start-val) - (number? end-val)) - (raise-exception (make-exception - (make-exception-with-message - "Non-number arguments given to simple-fade") - (make-exception-with-irritants - (list start-val end-val))))) - - (+ start-val - (* (- end-val start-val) - (elapsed-fraction clock)))) - - -(define (replace-noval val replacement) - (if (eq? 'no-value val) replacement val)) - - -(define (make-intensity-fade prev-val - target-val-in - up-clock - down-clock) - (let ((target-val (replace-noval target-val-in 0.0))) - - (cond - - ;; Number to number, fading up - ((and (number? target-val) - (number? prev-val) - (> target-val prev-val)) - (lambda () - (simple-fade prev-val - target-val - up-clock))) - - ;; Number to number, fading down - ((and (number? target-val) - (number? prev-val) - (< target-val prev-val)) - (lambda () - (simple-fade prev-val - target-val - down-clock))) - - ;; Number to number, staying the same - ;; NB We still need a static value so that fade-start-val can "unwrap" it - ((and (number? target-val) - (number? prev-val)) - (lambda () prev-val)) - - ;; Everything else, e.g. number to effect - (else - (lambda () - (max - (simple-fade (value->number prev-val) - 0 - down-clock) - (simple-fade 0 - (value->number target-val) - up-clock))))))) - - -(define (make-list-attr-fade start-val - target-val - clock) - (lambda () - (snap-fade start-val - target-val - clock))) - - -(define (make-general-fade fade-func - start-val - target-val - clock) - - (if (and (not (procedure? target-val)) - (not (eq? target-val 'no-value)) - (not (eq? start-val 'no-value))) - - ;; It makes sense to do a fade - (let ((real-start-val (value->number start-val))) - (lambda () - (fade-func real-start-val - target-val - clock))) - - ;; A fade doesn't make sense, so make do with a snap transition - (lambda () - (snap-fade start-val - target-val - clock)))) - - -(define (match-fix-attr attr-el fix attr) - (cond - - ((fixture? attr-el) - (eq? attr-el fix)) - - ((and (pair? attr-el) - (fixture? (car attr-el)) - (symbol? (cdr attr-el))) - (and (eq? (car attr-el) fix) - (eq? (cdr attr-el) attr))) - - ((list? attr-el) - (and (memq fix attr-el) - (memq attr attr-el))) - - (else #f))) - - -(define (in-cue-part? cue-part fix attr) - (find (lambda (p) (match-fix-attr p fix attr)) - (get-cue-part-attr-list cue-part))) - - -(define (cue-part-fade-times the-cue fix attr) - - (let ((the-cue-part - (find (lambda (p) (in-cue-part? p fix attr)) - (get-cue-parts the-cue)))) - - (if (cue-part? the-cue-part) - (get-cue-part-fade-times the-cue-part) - (get-cue-fade-times the-cue)))) - - -(define (fade-start-val pb fix attr) - (let ((val-in-pb (state-find fix attr pb))) - (if (eq? val-in-pb 'no-value) - - ;; Not currently in playback - fade from home value - (get-attr-home-val fix attr) - - ;; Currently in playback - fade from current value - ;; by running the outer crossfade function - (val-in-pb)))) - - -(define (dark? a) - (or (eq? a 'no-value) - (and (number? a) - (< a 1)))) - - -(define (longest-fade-time fade-times) - (max - (+ (get-fade-down-time fade-times) - (get-fade-down-delay fade-times)) - (+ (get-fade-up-time fade-times) - (get-fade-up-delay fade-times)) - (+ (get-fade-attr-time fade-times) - (get-fade-attr-delay fade-times)))) - - -;; Work out how long it will take before we can forget about this cue -(define (cue-total-time the-cue) - (let ((fade-times (cons (get-cue-fade-times the-cue) - (map get-cue-part-fade-times - (get-cue-parts the-cue))))) - (fold max - 0 - (map longest-fade-time fade-times)))) - - -(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 (fix-attrs-involved . states) - (fold add-fix-attrs-to-list '() states)) - - -(define (make-fade-for-attribute-type type) - (cond - ((eq? type 'continuous) (partial-start make-general-fade simple-fade)) - ((eq? type 'list) make-list-attr-fade) - ((eq? type 'colour) (partial-start make-general-fade colour-fade)) - (else - (raise-exception (make-exception - (make-exception-with-message - "Unrecognised attribute type") - (make-exception-with-irritants type)))))) +(define (blank-everything state) + (state-map + (lambda (fix attr val) + (if (intensity? attr) + 0.0 + 'no-value)) + state)) (define (run-cue-index! pb cue-index) (let* ((the-cue (vector-ref (get-playback-cue-list pb) cue-index)) - (this-cue-state (get-tracked-state the-cue)) (overlay-state (make-empty-state)) - (cue-clock (make-clock #:expiration-time (cue-total-time the-cue)))) - + (cue-clock (get-cue-clock the-cue)) + (fade-time 0)) + + ;; Start by fading the previous contents of the playback down, using the + ;; "main" transition effect + (receive + (overlay-part transition-time) + ((get-cue-part-transition + (car (get-cue-parts the-cue))) + (blank-everything pb) + pb + cue-clock) + (atomically-overlay-state! + overlay-state + overlay-part) + (set! fade-time transition-time)) + + ;; Stack all the cue parts on top (for-each - (lambda (fix-attr) - - (let* ((fix (car fix-attr)) - (attr (cdr fix-attr)) - (fade-times (cue-part-fade-times the-cue fix attr)) - - ;; The values for fading - (start-val (fade-start-val pb fix attr)) - (target-val (state-find fix attr this-cue-state)) - ;; The clocks for things in this cue part - (up-clock (make-delayed-clock cue-clock - (get-fade-up-delay fade-times) - (get-fade-up-time fade-times))) - - (down-clock (make-delayed-clock cue-clock - (get-fade-down-delay fade-times) - (get-fade-down-time fade-times))) - - (attribute-clock (make-delayed-clock cue-clock - (get-fade-attr-delay fade-times) - (get-fade-attr-time fade-times)))) - - (if (intensity? attr) - - ;; Intensity attribute - (set-in-state! overlay-state fix attr - (make-intensity-fade start-val - target-val - up-clock - down-clock)) - - ;; Non-intensity attribute - (let ((attribute-obj (find-attr fix attr))) - - (unless attribute-obj - (raise-exception (make-exception - (make-exception-with-message - "Attribute not found") - (make-exception-with-irritants - (list fix attr))))) - - (let* ((atype (get-attr-type attribute-obj)) - (make-fade-func (make-fade-for-attribute-type atype))) - - (set-in-state! overlay-state fix attr - (make-fade-func start-val - target-val - attribute-clock))))))) - - (fix-attrs-involved pb this-cue-state)) - + (lambda (part) + (receive + (overlay-part transition-time) + ((get-cue-part-transition part) + (get-cue-part-state part) + pb + cue-clock) + (atomically-overlay-state! + overlay-state + overlay-part) + (set! fade-time (max fade-time transition-time)))) + (get-cue-parts the-cue)) + + (set-clock-expiration-time! cue-clock fade-time) (atomically-overlay-state! pb overlay-state) - (set-cue-clock! pb cue-clock) + (set-pb-cue-clock! pb cue-clock) (set-running-cue! pb the-cue) - (set-playback-state! pb 'running))) - - -(define (print-playback pb) - (format #t "Playback ~a:\n" pb) - ;;(format #t " Cue list ~a\n" (get-playback-cue-list pb)) - (if (get-next-cue-index pb) - (if (< (get-next-cue-index pb) - (vector-length (get-playback-cue-list pb))) - (let ((the-cue (vector-ref (get-playback-cue-list pb) - (get-next-cue-index pb)))) - (format #t " Next cue index ~a (~a)\n" - (get-next-cue-index pb) - the-cue)) - (format #t " End of cue list.\n")) - (format #t " Next cue index is unspecified.\n")) - *unspecified*) - - -;;; ******************** Cue lists ******************** - -(define-syntax cue-part - (syntax-rules () - ((_ (fixtures ...) params ...) - (make-cue-part-obj (list fixtures ...) - params ...)))) - - -(define* (make-cue-part-obj attr-list - #:key - (up-time 5) - (down-time 5) - (attr-time 0) - (up-delay 0) - (down-delay 0) - (attr-delay 0)) - (make-cue-part attr-list - (make-fade-times - up-time - down-time - attr-time - up-delay - down-delay - attr-delay))) - - -(define cue - (lambda (number state . rest) - (receive (cue-parts rest-minus-cue-parts) - (partition cue-part? rest) - (let-keywords rest-minus-cue-parts #f - ((up-time 5) - (down-time 5) - (attr-time 0) - (up-delay 0) - (down-delay 0) - (attr-delay 0) - (preset-time 1) - (track-intensities #f)) - - (make-cue (qnum number) - state - #f ;; tracked state - #f ;; preset state - (make-fade-times - up-time - down-time - attr-time - up-delay - down-delay - attr-delay) - preset-time - track-intensities - cue-parts))))) - - -(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-state the-cue))))) - (set-tracked-state! the-cue the-tracked-state) - the-tracked-state)) - (make-empty-state) - the-cue-list)) - - -(define (fixture-dark-in-state? fix state) - (dark? (state-find fix 'intensity state))) - - -(define (preset-all-cues! the-cue-list) - (vector-fold-right - (lambda (idx next-state the-cue) - (let ((preset-state (make-empty-state))) + (reset-clock! cue-clock) + (start-clock! cue-clock) + (set-playback-state! pb 'running) + (write-recovery-file! pb (get-cue-number the-cue)))) - (state-for-each - (lambda (fix attr val) - (unless (intensity? attr) - (when (fixture-dark-in-state? fix (get-tracked-state the-cue)) - (set-in-state! preset-state fix attr val)))) - next-state) - (set-preset-state! the-cue preset-state)) +(define-method (num-cues (pb <starlet-playback>)) + (num-cues (get-playback-cue-list pb))) - ;; Pass the raw state from this cue to the previous one - (get-cue-state the-cue)) - (make-empty-state) - the-cue-list)) +(define (start-fixture-preset! pb) + (let ((st (get-preset-state (get-running-cue pb)))) + (state-for-each + (lambda (fix attr val) + (set-in-state! pb fix attr (lambda () val))) + st))) (define-method (update-state! (pb <starlet-playback>)) - (when (and (get-cue-clock pb) - (clock-expired? (get-cue-clock pb)) - (eq? 'running (atomic-box-ref (state-box pb)))) - (when (eq? 'running (atomic-box-compare-and-swap! (state-box pb) - 'running - 'ready)) - (run-hook (state-change-hook pb) 'ready) - (let ((st (get-preset-state (get-running-cue pb)))) - (state-for-each - (lambda (fix attr val) - (set-in-state! pb fix attr (lambda () val))) - st)) - (set-running-cue! pb #f)))) - - -(define-syntax cue-list - (syntax-rules () - ((_ body ...) - (let ((the-cue-list (vector (cue 0 - (make-empty-state) - #:up-time 0 - #:down-time 0 - #:attr-time 0 - #:preset-time 0) - body ...))) - (track-all-cues! the-cue-list) - (preset-all-cues! the-cue-list) - the-cue-list)))) + (when + (and (clock-expired? (get-pb-cue-clock pb)) + (eq? 'running (atomic-box-compare-and-swap! (state-box pb) + 'running + 'ready))) + (run-hook (state-change-hook pb) 'ready) + (start-fixture-preset! pb) + (set-running-cue! pb #f))) + + +(define (next-cue-number pb) + (let ((next-cue-index (get-next-cue-index pb)) + (the-cue-list (get-playback-cue-list pb))) + (if (< next-cue-index (vector-length the-cue-list)) + (exact->inexact + (cue-index-to-number + the-cue-list + next-cue-index)) + 'no-more-cues-in-list))) + + +(define (playback-state pb) + (atomic-box-ref (state-box pb))) + + +(define-method (write (pb <starlet-playback>) port) + (let ((cur-cue (get-playback-cue-number pb))) + (format port + "#<<starlet-playback> state: ~a current-cue: ~a next-cue: ~a>" + (playback-state pb) + (if cur-cue + (exact->inexact cur-cue) + 'current-cue-unspecified) + (if cur-cue + (next-cue-number pb) + 'next-cue-unspecified)))) + + +(define (reassert-current-cue! pb) + (let ((cur-cue (get-playback-cue-number pb))) + (if cur-cue + (cut-to-cue-number! pb cur-cue) + 'current-cue-unspecified))) diff --git a/guile/starlet/scanout.scm b/guile/starlet/scanout.scm index 4b7a2e1..69f3e9c 100644 --- a/guile/starlet/scanout.scm +++ b/guile/starlet/scanout.scm @@ -1,7 +1,7 @@ ;; ;; starlet/scanout.scm ;; -;; Copyright © 2020-2021 Thomas White <taw@bitwiz.org.uk> +;; Copyright © 2020-2023 Thomas White <taw@bitwiz.org.uk> ;; ;; This file is part of Starlet. ;; @@ -19,294 +19,140 @@ ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;; (define-module (starlet scanout) + #:use-module (starlet engine) #:use-module (starlet fixture) #:use-module (starlet state) #:use-module (starlet utils) - #:use-module (starlet colours) + #:use-module (starlet attributes) #:use-module (starlet guile-ola) - #:use-module (oop goops) #:use-module (ice-9 threads) #:use-module (ice-9 atomic) #:use-module (ice-9 exceptions) - #:use-module (srfi srfi-1) - #:export (patch-fixture! - patch-many! - scanout-freq - total-num-attrs - register-state! - current-value - patched-fixture-names)) + #:export (scanout-freq + get-attr + set-chan8 + set-chan16)) -;; The list of patched fixtures -(define fixtures (make-atomic-box '())) - -;; List of states being scanned out -(define state-list (make-atomic-box '())) - -;; Association list of names to states -(define state-names (make-atomic-box '())) - - -(define (patched-fixture-names) - (map get-fixture-name (atomic-box-ref fixtures))) - - -(define (total-num-attrs) - (fold (lambda (fix prev) - (+ prev (length (get-fixture-attrs fix)))) - 0 - (atomic-box-ref fixtures))) - - -(define (get-state-name st) - (assq-ref (atomic-box-ref state-names) - st)) - - -(define (set-state-name! st name) - (atomic-box-set! state-names - (assq-set! (atomic-box-ref state-names) - st - name))) - - -;; Patch a new fixture -(define* (patch-real name - class - start-addr - #:key (universe 0) (friendly-name "Fixture")) - (let ((new-fixture (make class - #:name name - #:sa start-addr - #:uni universe - #:friendly-name friendly-name))) - (atomic-box-set! fixtures (cons new-fixture - (atomic-box-ref fixtures))) - new-fixture)) - - -(define-syntax patch-fixture! - (syntax-rules () - ((_ name stuff ...) - (define name (patch-real (quote name) stuff ...))))) - - -;; Patch several new fixtures -(define* (patch-many-real name - class - start-addrs - #:key (universe 0) (friendly-name "Fixture")) - (map (lambda (start-addr n) - (patch-real `(list-ref ,name ,n) - class - start-addr - #:universe universe - #:friendly-name friendly-name)) - start-addrs - (iota (length start-addrs)))) - - -(define-syntax patch-many! - (syntax-rules () - ((_ name stuff ...) - (define name (patch-many-real (quote name) stuff ...))))) - - -(define (state-has-fix-attr fix attr state) - (let ((val (state-find fix attr state))) - (if (eq? 'no-value val) - #f - (not (eq? 'no-value (value->number val)))))) - - -(define (first-val fix attr state-list) - (let ((first-state (find (lambda (state) - (state-has-fix-attr fix attr state)) - state-list))) - (if first-state - (state-find fix attr first-state) - 'no-value))) - - -(define-method (current-value (fix <fixture>) (attr-name <symbol>)) - (let ((programmer-val (state-find fix attr-name programmer-state))) - (if (eq? 'no-value programmer-val) - - ;; Look in the states - (if (intensity? attr-name) - - ;; HTP for intensity - (fold (lambda (state prev) - (let ((val (state-find fix attr-name state))) - (if (eq? 'no-value val) - prev - (let ((real-val (value->number val))) - (if (eq? 'no-value real-val) - prev - (max real-val prev)))))) - 0.0 - (atomic-box-ref state-list)) - - ;; Priority order for everything else - (let ((val (first-val fix attr-name (atomic-box-ref state-list)))) - (if (eq? 'no-value val) - (get-attr-home-val fix attr-name) - (value->number val)))) - - ;; Use programmer value, if we have it - (value->number programmer-val)))) - - -(define-method (current-value (fix <fixture>) (attr-name <colour-component-id>)) - (let ((colour (current-value fix 'colour))) - (extract-colour-component colour attr-name))) - - -(define (append-or-replace-named-state orig-list name new-state) - (let ((new-list (map (lambda (st) - (if (eq? (get-state-name st) name) - (begin - new-state) - st)) - orig-list))) - - ;; If there is no state with this name in the list, - ;; the replacement above will have no effect. - ;; Check again and add in the normal way if so. - (if (find (lambda (st) (eq? (get-state-name st) - name)) - new-list) - new-list - (append orig-list (list new-state))))) +(define scanout-thread #f) +(define scanout-freq 0) +(define current-scanout-fixture (make-parameter #f)) +(define current-scanout-universe (make-parameter #f)) +(define current-scanout-addr (make-parameter #f)) +(define current-scanout-state (make-parameter (make-empty-state))) -(define* (register-state! new-state - #:key (unique-name #f)) - (if unique-name - (begin (set-state-name! new-state unique-name) - (atomic-box-set! state-list - (append-or-replace-named-state (atomic-box-ref state-list) - unique-name - new-state))) - (atomic-box-set! state-list - (append (atomic-box-ref state-list) - (list new-state))))) +(define (get-attr attr-name) + (let ((v (state-find (current-scanout-fixture) + attr-name + (current-scanout-state)))) + (if (eq? v 'no-value) + (get-attr-home-val (current-scanout-fixture) attr-name) + v))) -(define (msb val) - (round-dmx (euclidean-quotient val 256))) -(define (lsb val) - (round-dmx (euclidean-remainder val 256))) +(define (set-dmx universe addr value) + (ensure-number value (list universe addr value)) + ;; Create DMX array for universe if it doesn't exist already + (set-ola-dmx-buffer! universe + (- addr 1) ; OLA indexing starts from zero + (round-dmx value))) -(define (send-to-ola ola-client universe-buffer-pair) - (let ((uni (car universe-buffer-pair)) - (buf (cdr universe-buffer-pair))) - (send-streaming-dmx-data! ola-client uni buf))) +(define (set-chan8 relative-channel-number value) + (ensure-number + value + (list (current-scanout-fixture) + relative-channel-number + value)) + (set-dmx + (current-scanout-universe) + (+ (current-scanout-addr) + relative-channel-number + -1) + value)) -(define (ensure-number value irritating) - (unless (number? value) - (raise-exception (make-exception - (make-exception-with-message "Value is not a number") - (make-exception-with-irritants irritating))))) +(define (set-chan16 relative-channel-number value) + (ensure-number + value + (list (current-scanout-fixture) + relative-channel-number + value)) + (set-chan8 relative-channel-number (msb value)) + (set-chan8 (+ relative-channel-number 1) (lsb value))) -(define scanout-freq 0) -(define ola-thread #f) -(define (scanout-loop ola-client start-time count previous-universes) +(define (scanout-loop ola-client start-time previous-universes count) (let ((universes '())) - ;; Helper function for scanout functions to set individual DMX values - (define (set-dmx universe addr value) - (ensure-number value (list universe addr value)) + (parameterize + ((current-scanout-state (current-value-state))) + (for-each + (lambda (fix) - ;; Create DMX array for universe if it doesn't exist already - (unless (assq universe universes) - (set! universes (acons universe - (make-ola-dmx-buffer) - universes))) + ;; Ensure the DMX array exists for this fixture's universe + (unless (assq (get-fixture-universe fix) universes) + (set! universes (acons (get-fixture-universe fix) + (make-ola-dmx-buffer) + universes))) - (set-ola-dmx-buffer! (assq-ref universes universe) - (- addr 1) ; OLA indexing starts from zero - (round-dmx value))) + (parameterize + ((current-scanout-fixture fix) + (current-scanout-universe (assq-ref + universes + (get-fixture-universe fix))) + (current-scanout-addr (get-fixture-addr fix))) + (scanout-fixture fix))) - (for-each update-state! (atomic-box-ref state-list)) + (patched-fixtures))) (for-each - (lambda (fix) - - (let ((univ (get-fixture-universe fix)) - (addr (get-fixture-addr fix))) - - ;; Helper function to get a value for this - ;; fixture in the current state - (define (get-attr attr-name) - (current-value fix attr-name)) - - ;; Helper function to set 8-bit DMX value - (define (set-chan relative-channel-number value) - (ensure-number value (list fix relative-channel-number value)) - (set-dmx univ (+ addr relative-channel-number -1) value)) - - ;; Helper function to set 16-bit DMX value - (define (set-chan-16bit relative-channel-number value) - (ensure-number value (list fix relative-channel-number value)) - (set-chan relative-channel-number (msb value)) - (set-chan (+ relative-channel-number 1) (lsb value))) - - (scanout-fixture fix get-attr set-chan set-chan-16bit))) - - (atomic-box-ref fixtures)) - - ;; Send everything to OLA - (for-each (lambda (uni-buf-pair) - (let ((uni (car uni-buf-pair)) - (buf (cdr uni-buf-pair))) - (let ((prev-buf (assv-ref previous-universes uni))) - - ;; Do not send exactly the same data every time, - ;; but do send an update once every 100 loops, just to - ;; make sure OLA does not forget about us. - (unless (and prev-buf - (ola-dmx-buffers-equal? buf prev-buf) - (not (= count 0))) - (send-streaming-dmx-data! ola-client uni buf))))) - universes) - - (usleep 10000) - - ;; Update scanout rate every 1000 cycles + (lambda (uni-buf-pair) + (let ((uni (car uni-buf-pair)) + (buf (cdr uni-buf-pair))) + (let ((prev-buf (assv-ref previous-universes uni))) + + ;; Do not send exactly the same data every time, + ;; but do send an update once every 100 loops, just to + ;; make sure OLA does not forget about us. + (unless (and prev-buf + (ola-dmx-buffers-equal? buf prev-buf) + (not (= count 0))) + (send-streaming-dmx-data! ola-client uni buf))))) + universes) + + (usleep 20000) + + ;; Update output rate every 1000 cycles (if (eq? count 100) - (begin - (set! scanout-freq - (exact->inexact (/ 100 - (- (hirestime) start-time)))) - (scanout-loop ola-client (hirestime) 0 universes)) - (scanout-loop ola-client start-time (+ count 1) universes)))) - - -(define (start-ola-output) - (if ola-thread - (format #t "OLA output already running\n") - (let* ((ola-client (make-ola-streaming-client)) - (start-time (hirestime))) - - (set! ola-thread - (begin-thread - (with-exception-handler - (lambda (exn) - (display "Error in OLA output thread:\n") - (set! ola-thread #f) - (backtrace) - (raise-exception exn)) - (lambda () - (scanout-loop ola-client start-time 0 '())) - #:unwind? #f)))))) - - -(start-ola-output) + (begin + (set! scanout-freq + (exact->inexact (/ 100 + (- (hirestime) start-time)))) + (scanout-loop ola-client (hirestime) universes 0)) + (scanout-loop ola-client start-time universes (+ count 1))))) + + +(define (start-scanout) + (if scanout-thread + (format #t "Scanout thread is already running\n") + (let ((start-time (hirestime)) + (ola-client (make-ola-streaming-client))) + (set! scanout-thread + (begin-thread + (with-exception-handler + (lambda (exn) + (display "Error in scanout thread:\n") + (set! scanout-thread #f) + (backtrace) + (raise-exception exn)) + (lambda () + (scanout-loop ola-client start-time '() 0)) + #:unwind? #f)))))) + + +(start-scanout) diff --git a/guile/starlet/selection.scm b/guile/starlet/selection.scm new file mode 100644 index 0000000..2798fc1 --- /dev/null +++ b/guile/starlet/selection.scm @@ -0,0 +1,97 @@ +;; +;; starlet/selection.scm +;; +;; Copyright © 2020-2023 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 selection) + #:use-module (starlet utils) + #:use-module (starlet fixture) + #:use-module (srfi srfi-1) + #:export (sel + add-sel + toggle-sel + desel + selection-hook + get-selection + get-selection-as-string + selected?)) + + +(define selection-hook (make-hook 1)) + +(define selection '()) + + +(define (get-selection) + selection) + + +(define (dotted-fixture-name s) + (with-output-to-string + (lambda () + (format #t "~a.~a" (second s) (third s))))) + + +(define (get-selection-as-string) + (cat-with-spaces + (map + (lambda (s) + (let ((name (get-fixture-name s))) + (if (symbol? name) + (symbol->string name) + (dotted-fixture-name name)))) + selection))) + + +(define (sel . fixture-list) + (if (nil? fixture-list) + (set! selection '()) + (if (not (car fixture-list)) + (set! selection '()) + (set! selection (flatten-sublists fixture-list)))) + (run-hook selection-hook selection)) + + +(define (toggle-sel . fixture-list) + (if (selected? fixture-list) + (desel fixture-list) + (add-sel fixture-list))) + + +(define (add-sel . fixture-list) + (set! selection + (append selection + (filter (lambda (fix) + (not (selected? fix))) + (flatten-sublists fixture-list)))) + (run-hook selection-hook selection)) + + +(define (selected? . fixture-list) + (every (lambda (fix) + (memq fix selection)) + (flatten-sublists fixture-list))) + + +(define (desel . fixture-list) + (let ((remove-us (flatten-sublists fixture-list))) + (set! selection + (filter (lambda (fix) + (not (memq fix remove-us))) + selection))) + (run-hook selection-hook selection)) diff --git a/guile/starlet/snap-transition.scm b/guile/starlet/snap-transition.scm new file mode 100644 index 0000000..46993cd --- /dev/null +++ b/guile/starlet/snap-transition.scm @@ -0,0 +1,51 @@ +;; +;; starlet/snap-transition.scm +;; +;; Copyright © 2021-2023 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 snap-transition) + #:use-module (starlet cue-part) + #:use-module (starlet state) + #:use-module (starlet attributes) + #:export (snap)) + + +(define (blank-everything in-state) + (let ((out-state (make-empty-state))) + (state-for-each + (lambda (fix attr val) + (if (intensity? attr) + (set-in-state! out-state fix attr (lambda () 0.0)) + (set-in-state! out-state fix attr (lambda () 'no-value)))) + in-state) + out-state)) + + +(define (snap to-state) + (cue-part + to-state + (lambda (incoming-state current-state clock) + (let ((overlay-state (blank-everything current-state))) + (state-for-each + (lambda (fix attr val) + (set-in-state! overlay-state + fix + attr + (lambda () val))) + incoming-state) + (values overlay-state 0))))) diff --git a/guile/starlet/state.scm b/guile/starlet/state.scm index 6abd3c1..588e887 100644 --- a/guile/starlet/state.scm +++ b/guile/starlet/state.scm @@ -1,7 +1,7 @@ ;; ;; starlet/state.scm ;; -;; Copyright © 2020-2021 Thomas White <taw@bitwiz.org.uk> +;; Copyright © 2020-2022 Thomas White <taw@bitwiz.org.uk> ;; ;; This file is part of Starlet. ;; @@ -20,18 +20,22 @@ ;; (define-module (starlet state) #:use-module (starlet fixture) - #:use-module (starlet colours) #:use-module (starlet utils) + #:use-module (starlet attributes) + #:use-module (starlet selection) #:use-module (oop goops) #:use-module (ice-9 pretty-print) #:use-module (ice-9 atomic) #:use-module (ice-9 receive) #:use-module (ice-9 exceptions) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:export (<starlet-state> make-empty-state + lighting-state? get-state-name state-for-each + state-map->list state-map copy-state clear-state! @@ -42,22 +46,26 @@ current-state at apply-state + combine-states show-state lighting-state programmer-state + ps home-fixture! + blackout blackout! - sel - selection-hook - get-selection value->number atomically-overlay-state! update-state! - add-update-hook!)) + add-update-hook! + state-empty? + remove-fixtures-from-state! + remove-fixture-from-state! + remove-selection-from-programmer!)) ;; A "state" is an atomically-updating container for an immutable -;; hash table mapping (fixture-object . attribute-symbol) pairs to values +;; hash table mapping (fixture-object . attribute-name-object) pairs to values ;; which can be numbers, symbols, colours, boolean values and more ;; depending on the type of attribute. Values can also be ;; functions which provide the value. @@ -66,12 +74,17 @@ #:init-form (make-atomic-box (make-hash-table)) #:getter get-ht-box) (update-hook - #:init-form (make-hook 4) + #:init-form (make-hook 1) #:getter get-update-hook)) +(define (lighting-state? a) + (is-a? a <starlet-state>)) + + ;; The state used to build a new scene for recording (define programmer-state (make <starlet-state>)) +(define ps programmer-state) (define (add-update-hook! state proc) @@ -80,10 +93,10 @@ (define (find-colour state fix) - (let ((col (state-find fix 'colour state))) + (let ((col (state-find fix colour state))) (if (eq? 'no-value col) - (let ((home-col (get-attr-home-val fix 'colour))) + (let ((home-col (get-attr-home-val fix colour))) (if (eq? 'fixture-does-not-have-attribute home-col) (raise-exception (make-exception (make-exception-with-message @@ -101,66 +114,7 @@ (define-method (set-in-state! (state <starlet-state>) (fix <fixture>) - (attr <colour-component-id>) - new-val - source) - (let ((current-colour (find-colour state fix)) - (colour-component (get-colour-component attr))) - - (cond - - ((eq? colour-component 'cyan) - (let ((orig-colour (colour-as-cmy current-colour))) - (set-in-state! state fix 'colour - (make-colour-cmy new-val - (magenta orig-colour) - (yellow orig-colour)) - source))) - - ((eq? colour-component 'magenta) - (let ((orig-colour (colour-as-cmy current-colour))) - (set-in-state! state fix 'colour - (make-colour-cmy (cyan orig-colour) - new-val - (yellow orig-colour)) - source))) - - ((eq? colour-component 'yellow) - (let ((orig-colour (colour-as-cmy current-colour))) - (set-in-state! state fix 'colour - (make-colour-cmy (cyan orig-colour) - (magenta orig-colour) - new-val) - source))) - - ((eq? colour-component 'red) - (let ((orig-colour (colour-as-rgb current-colour))) - (set-in-state! state fix 'colour - (make-colour-rgb new-val - (green orig-colour) - (blue orig-colour)) - source))) - - ((eq? colour-component 'green) - (let ((orig-colour (colour-as-rgb current-colour))) - (set-in-state! state fix 'colour - (make-colour-rgb (red orig-colour) - new-val - (blue orig-colour)) - source))) - - ((eq? colour-component 'blue) - (let ((orig-colour (colour-as-rgb current-colour))) - (set-in-state! state fix 'colour - (make-colour-rgb (red orig-colour) - (green orig-colour) - new-val) - source)))))) - - -(define-method (set-in-state! (state <starlet-state>) - (fix <fixture>) - (attr <symbol>) + (attr <starlet-attribute>) value source) (let* ((old-ht (atomic-box-ref (get-ht-box state))) @@ -175,27 +129,16 @@ old-ht) (set-in-state! state fix attr)) ;; Try again - (run-hook (get-update-hook state) - fix - attr - value - source))) + (run-hook (get-update-hook state) source))) (define-method (set-in-state! (state <starlet-state>) (fix <fixture>) - (attr <symbol>) + (attr <starlet-attribute>) value) (set-in-state! state fix attr value #f)) -(define-method (set-in-state! (state <starlet-state>) - (fix <fixture>) - (attr <colour-component-id>) - new-val) - (set-in-state! state fix attr new-val #f)) - - ;; Set any intensity attributes in the current state to zero (define (blackout!) (let ((state (current-state))) @@ -228,6 +171,10 @@ (make <starlet-state>)) +(define blackout + (make-empty-state)) + + (define (state-for-each func state) (hash-for-each (lambda (key value) (func (car key) @@ -236,24 +183,13 @@ (atomic-box-ref (get-ht-box state)))) -(define-method (state-find (fix <fixture>) - (attr <symbol>) - (state <starlet-state>)) +(define (state-find fix attr state) (hash-ref (atomic-box-ref (get-ht-box state)) (cons fix attr) 'no-value)) -(define-method (state-find (fix <fixture>) - (attr <colour-component-id>) - (state <starlet-state>)) - (let ((col (state-find fix 'colour state))) - (if (eq? 'no-value col) - 'no-value - (extract-colour-component col attr)))) - - -(define (state-map func state) +(define (state-map->list func state) (hash-map->list (lambda (key value) (func (car key) (cdr key) @@ -261,6 +197,21 @@ (atomic-box-ref (get-ht-box state)))) +(define (state-map func state) + (let ((out-state (make-empty-state))) + (hash-for-each + (lambda (key value) + (set-in-state! + out-state + (car key) + (cdr key) + (func (car key) + (cdr key) + value))) + (atomic-box-ref (get-ht-box state))) + out-state)) + + (define (apply-state state) "Apply the contents of 'state' to the current state, on top of the \ pre-existing contents." @@ -301,9 +252,20 @@ pre-existing contents." (current-state))))) +(define (combine-states a b) + (lighting-state + (apply-state a) + (apply-state b))) + + (define (print-state a) (pretty-print (state-source a))) +(define-method (write (st <starlet-state>) port) + (write + (state-source st) + port)) + (define (clamp-to-attr-range fix attr val) (if (number? val) @@ -316,14 +278,21 @@ pre-existing contents." val)) +(define (quote-if-symbol a) + (if (symbol? a) + (list 'quote a) + a)) + + (define (state-source a) (cons 'lighting-state - (state-map (lambda (fix attr val) - (list 'at - (get-fixture-name fix) - (list 'quote attr) - (clamp-to-attr-range fix attr val))) - a))) + (state-map->list (lambda (fix attr val) + (list 'at + (get-fixture-name fix) + (canonical-name attr) + (quote-if-symbol + (clamp-to-attr-range fix attr val)))) + a))) ;; Coerce something from a state object into a number for scanout @@ -343,8 +312,7 @@ pre-existing contents." old-ht) (clear-state! state))) ;; Try again - (run-hook (get-update-hook state) - '() #f #f #f)) + (run-hook (get-update-hook state) #f)) (define (partition3 pred1 pred2 input) @@ -355,69 +323,87 @@ pre-existing contents." (values output1 output2 others)))) -(define (set-fixtures fixtures attr-name value) - (for-each (lambda (fix) - (set-in-state! (current-state) - fix - (car attr-name) - (clamp-to-attr-range fix - (car attr-name) - (car value)))) - fixtures)) +(define (set-fixtures fixtures attribute value) + (for-each + (lambda (fix) + (if (fixture-has-attr? fix attribute) + (set-in-state! (current-state) + fix + attribute + (clamp-to-attr-range fix attribute value)) + (error "Fixture does not have attribute" + (get-fixture-name fix) + (canonical-name attribute)))) + fixtures)) ;; (at <fixtures/groups> [<attribute>] <level> [<attribute> <level>...]) ;; (at fix1 100) <-- Set intensity of single fixture -;; (at fix1 'intensity 100) <-- Explicit attribute name +;; (at fix1 intensity 100) <-- Explicit attribute name ;; (at fix1 fix2 100) <-- Multiple fixtures -;; (at fix1 fix2 'pan 36) <-- Multiple fixtures + explicit attribute -;; (at group1 fix1 'intensity 100) <-- Groups can be used instead of fixtures -;; (at fix1 100 'pan 36) <-- Set multiple attributes -;; NB Can't set multiple fixtures and attributes: (at fix1 'pan 35 fix2 'tilt 22) +;; (at fix1 fix2 pan 36) <-- Multiple fixtures + explicit attribute +;; (at group1 fix1 intensity 100) <-- Groups can be used instead of fixtures +;; (at fix1 100 pan 36) <-- Set multiple attributes +;; NB Can't set multiple fixtures and attributes: (at fix1 pan 35 fix2 tilt 22) (define (at . args) - (receive (fixtures attr-name value) - (partition3 fixture? symbol? (flatten-sublists args)) + (let ((selection (get-selection))) + (receive (fixtures attribute value) + (partition3 fixture? attribute? (flatten-sublists args)) (cond ((nil? value) (error "at: Value not specified")) ((or (more-than-one value) - (more-than-one attr-name)) + (more-than-one attribute)) (error "at: Only one attribute or value name")) ((and (nil? fixtures) - (nil? attr-name)) + (nil? attribute)) (if (nil? selection) 'no-fixtures-selected - (set-fixtures selection '(intensity) value))) + (set-fixtures selection intensity (car value)))) - ((nil? attr-name) - (set-fixtures fixtures '(intensity) value)) + ((nil? attribute) + (set-fixtures fixtures intensity (car value))) ((nil? fixtures) (if (nil? selection) 'no-fixtures-selected - (set-fixtures selection attr-name value))) + (set-fixtures selection (car attribute) (car value)))) (else - (set-fixtures fixtures attr-name value))))) + (set-fixtures fixtures (car attribute) (car value))))))) -(define selection-hook (make-hook 1)) +(define (state-empty? st) + (hash-table-empty? + (atomic-box-ref + (get-ht-box st)))) -(define selection '()) -(define (get-selection) - selection) +(define (remove-fixtures-from-state! st fixture-list) + (let ((new-ht (make-hash-table)) + (old-ht (atomic-box-ref (get-ht-box st)))) + (state-for-each + (lambda (fix attr val) + (unless (memq fix fixture-list) + (hash-set! new-ht (cons fix attr) val))) + st) + (if (eq? old-ht (atomic-box-compare-and-swap! + (get-ht-box st) + old-ht + new-ht)) + (run-hook (get-update-hook st) #f) + (remove-fixtures-from-state! st fixture-list)))) + +(define (remove-fixture-from-state! st fix) + (remove-fixtures-from-state! st (list fix))) -(define (sel . fixture-list) - (if (nil? fixture-list) - (set! selection '()) - (if (not (car fixture-list)) - (set! selection '()) - (set! selection (flatten-sublists fixture-list)))) - (run-hook selection-hook selection)) +(define (remove-selection-from-programmer!) + (remove-fixtures-from-state! + programmer-state + (get-selection))) diff --git a/guile/starlet/utils.scm b/guile/starlet/utils.scm index d5441cb..1506553 100644 --- a/guile/starlet/utils.scm +++ b/guile/starlet/utils.scm @@ -20,15 +20,30 @@ ;; (define-module (starlet utils) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-8) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 control) #:export (print-hash-table copy-hash-table - partial - partial-start in-range mean flatten-sublists more-than-one - hirestime)) + hirestime + lsb + msb + ensure-number + round-dmx + scale-to-range + scale-and-clamp-to-range + percent->dmxval8 + percent->dmxval16 + comment + hash-table-empty? + lookup + add-and-run-hook! + cat-with-spaces + next-item-in-list)) (define (print-hash-table ht) @@ -47,15 +62,6 @@ new-ht)) -(define (partial f second-val) - (lambda (first-val) - (f first-val second-val))) - - -(define (partial-start f first-val) - (lambda args - (apply f first-val args))) - (define (in-range a val1 val2) (or @@ -71,15 +77,12 @@ (define (flatten-sublists l) - - (define (listify a) - (if (list? a) - a - (list a))) - - (fold (lambda (a prev) - (append prev (listify a))) - '() l)) + (fold + (lambda (el prev) + (if (list? el) + (append (flatten-sublists el) prev) + (cons el prev))) + '() l)) (define (more-than-one a) @@ -94,3 +97,101 @@ (/ (cdr a) 1000000)))) + +(define (msb val) + (round-dmx (euclidean-quotient val 256))) + +(define (lsb val) + (round-dmx (euclidean-remainder val 256))) + + +(define (round-dmx a) + (inexact->exact + (min 255 (max 0 (round a))))) + + +(define (ensure-number value irritating) + (unless (number? value) + (raise-exception (make-exception + (make-exception-with-message "Value is not a number") + (make-exception-with-irritants irritating))))) + + +(define (percent->dmxval8 val) + (round-dmx + (scale-to-range val '(0 100) '(0 255)))) + + +(define (percent->dmxval16 val) + (scale-to-range val '(0 100) '(0 65535))) + + +(define (scale-to-range val orig-range dest-range) + + (define (range r) + (- (cadr r) (car r))) + + (+ (car dest-range) + (* (range dest-range) + (/ (- val (car orig-range)) + (range orig-range))))) + + +(define (clamp-to-range val val1 val2) + (let ((minval (min val1 val2)) + (maxval (max val1 val2))) + (max minval + (min val maxval)))) + + +;; Like scale-to-range, but result is clamped within dest-range +(define (scale-and-clamp-to-range val orig-range dest-range) + (clamp-to-range + (scale-to-range val orig-range dest-range) + (car dest-range) + (cadr dest-range))) + + +(define-syntax comment + (syntax-rules () + ((_ body ...) + #f))) + + +(define (hash-table-empty? ht) + (let/ec + return + (hash-for-each-handle + (lambda (key) + (return #f)) + ht) + #t)) + + +(define (lookup key dictionary) + (cond + ((nil? dictionary) + #f) + ((eq? key (caar dictionary)) + (cadr (car dictionary))) + (else + (lookup key (cdr dictionary))))) + + +(define (add-and-run-hook! hook proc . initial-args) + (add-hook! hook proc) + (apply proc initial-args)) + + +(define (cat-with-spaces lst) + (reduce + (lambda (b a) + (string-append a " " b)) + "" lst)) + + +(define (next-item-in-list the-list cval) + (let ((sl (memq cval the-list))) + (if (nil? (cdr sl)) + (first the-list) + (second sl)))) diff --git a/meson.build b/meson.build index 6edbd81..6b652ff 100644 --- a/meson.build +++ b/meson.build @@ -20,6 +20,7 @@ pango_dep = dependency('pango', required: true) pangocairo_dep = dependency('pangocairo', required: true) guile_dep = dependency('guile-3.0', required: true) ola_dep = dependency('libola', required: true) +lo_dep = dependency('liblo', required: true) # The installation location for Scheme files guile_sitedir = guile_dep.get_pkgconfig_variable('sitedir') @@ -39,7 +40,8 @@ executable('starlet-fixture-display', cairo_dep, pango_dep, pangocairo_dep, - guile_dep], + guile_dep, + lo_dep], install: true) diff --git a/src/repl-connection.c b/src/repl-connection.c index 2e3201f..72446e7 100644 --- a/src/repl-connection.c +++ b/src/repl-connection.c @@ -153,6 +153,12 @@ static void input_ready(GObject *source, GAsyncResult *res, gpointer vp) printf("Prompt!\n"); repl->input[0] = '\0'; } + if ( strncmp(remaining, "Entering a new prompt", 21) == 0 ) { + fprintf(stderr, "Scheme error!\n"); + g_object_unref(repl->conn); + repl->conn = NULL; + return; + } free(remaining); g_input_stream_read_async(g_io_stream_get_input_stream(G_IO_STREAM(repl->conn)), diff --git a/src/starlet-fixture-display.c b/src/starlet-fixture-display.c index 35e40bc..ae7bc5e 100644 --- a/src/starlet-fixture-display.c +++ b/src/starlet-fixture-display.c @@ -29,6 +29,7 @@ #include <glib.h> #include <glib/gstdio.h> #include <libguile.h> +#include <lo/lo.h> #include <libintl.h> #define _(x) gettext(x) @@ -37,6 +38,7 @@ #define OVERALL_BORDER (20.0) +#define STATUS_HEIGHT (35.0) #define FIXTURE_BORDER (5.0) @@ -45,31 +47,63 @@ struct fixture char *label; char *scheme_name; double intensity; + double rgb[3]; int selected; + double min_x; + double min_y; + double max_x; + double max_y; }; struct fixture_display { - double fixture_tile_width; struct fixture *fixtures; int n_fixtures; + double current_cue_number; + int cue_running; + double scanout_rate; + int programmer_empty; + char *playback_name; GtkWidget *da; ReplConnection *repl; int shutdown; + char *socket; + int verbose; + int got_eof; + lo_server osc_srv; }; +static void show_vertical_center_log(cairo_t *cr, PangoLayout *layout, + double x, double h) +{ + int layw, layh; + pango_layout_get_pixel_size(layout, &layw, &layh); + cairo_move_to(cr, x, (h-layh)/2.0); + pango_cairo_show_layout(cr, layout); +} + + static void draw_fixture(cairo_t *cr, PangoContext *pc, PangoFontDescription *fontdesc, struct fixture_display *fixd, - struct fixture *fix) + struct fixture *fix, + double *pw, double *ph) { PangoLayout *layout; - const double w = 40.0; - const double h = 3.0/2.0*w; + double w = 180.0; + const double lh = 20.0; + const double inner_margin = 3.0; + int n_lines = 2; + double h = n_lines * lh + 2*inner_margin; + + *pw = w; + *ph = h; + + cairo_save(cr); /* Pan/tilt (underneath rectangle) */ // if ( fix->cls->attributes & PANTILT ) { // @@ -90,42 +124,88 @@ static void draw_fixture(cairo_t *cr, // // } - cairo_rectangle(cr, 0.0, 0.0, w, h); + cairo_rectangle(cr, 0.5, 0.5, w, h); if ( fix->selected ) { - cairo_set_source_rgba(cr, 0.3, 0.3, 0.9, 0.9); + cairo_set_source_rgba(cr, 0.3, 0.5, 0.2, 1.0); + cairo_fill_preserve(cr); + cairo_set_line_width(cr, 2.0); + cairo_set_source_rgb(cr, 0.0, 1.0, 0.0); + cairo_stroke(cr); } else { - cairo_set_source_rgba(cr, 0.3, 0.3, 0.3, 0.9); + cairo_set_source_rgba(cr, 0.0, 0.0, 0.0, 1.0); + cairo_fill_preserve(cr); + cairo_set_line_width(cr, 1.0); + cairo_set_source_rgb(cr, 0.0, 0.6, 0.0); + cairo_stroke(cr); } - cairo_fill_preserve(cr); - cairo_set_source_rgb(cr, 1.0, 1.0, 1.0); - cairo_set_line_width(cr, 1.0); - cairo_stroke(cr); + + /* Margin inside fixture rectangle */ + cairo_translate(cr, inner_margin, inner_margin); + w -= 2.0*inner_margin; + h -= 2.0*inner_margin; /* Label */ layout = pango_layout_new(pc); pango_layout_set_text(layout, fix->label, -1); - pango_layout_set_width(layout, (w*PANGO_SCALE)-4.0); - pango_layout_set_alignment(layout, PANGO_ALIGN_CENTER); + pango_layout_set_height(layout, lh*PANGO_SCALE); pango_layout_set_font_description(layout, fontdesc); cairo_set_source_rgb(cr, 1.0, 1.0, 1.0); - cairo_move_to(cr, 0.0, 2.0); - pango_cairo_show_layout(cr, layout); + show_vertical_center_log(cr, layout, 0.0, lh); g_object_unref(layout); + cairo_translate(cr, 0.0, lh); + + /* Colour */ + cairo_rectangle(cr, 1.0, 0.0, w*0.25, lh); + cairo_set_source_rgba(cr, fix->rgb[0], fix->rgb[1], fix->rgb[2], 1.0); + cairo_fill(cr); + + /* Mimic */ + cairo_set_source_rgba(cr, + fix->intensity * fix->rgb[0] / 100.0, + fix->intensity * fix->rgb[1] / 100.0, + fix->intensity * fix->rgb[2] / 100.0, + 1.0); + cairo_rectangle(cr, w*0.25+2.0, 0.0, w*0.75-2.0, lh); + cairo_fill(cr); /* Intensity */ if ( fix->intensity >= 0.0 ) { char tmp[32]; - snprintf(tmp, 32, "%.0f %%", fix->intensity); + double grey; + snprintf(tmp, 32, "%.0f%%", fix->intensity); layout = pango_layout_new(pc); pango_layout_set_text(layout, tmp, -1); - pango_layout_set_width(layout, (w*PANGO_SCALE)-4.0); - pango_layout_set_alignment(layout, PANGO_ALIGN_CENTER); + pango_layout_set_height(layout, lh*PANGO_SCALE); pango_layout_set_font_description(layout, fontdesc); - cairo_set_source_rgb(cr, 1.0, 1.0, 1.0); - cairo_move_to(cr, 0.0, 15.0); - pango_cairo_show_layout(cr, layout); + + if ( fix->intensity < 50.0 ) { + grey = 1.0; + } else { + grey = 0.0; + } + cairo_set_source_rgb(cr, grey, grey, grey); + + show_vertical_center_log(cr, layout, w*0.3, lh); g_object_unref(layout); } + + cairo_restore(cr); +} + + +static void plot_text(cairo_t *cr, const char *text, + PangoContext *pc, PangoFontDescription *fontdesc, + double x, double y) +{ + PangoLayout *layout; + + layout = pango_layout_new(pc); + pango_layout_set_text(layout, text, -1); + pango_layout_set_font_description(layout, fontdesc); + cairo_set_source_rgb(cr, 1.0, 1.0, 1.0); + cairo_move_to(cr, x, y); + pango_cairo_show_layout(cr, layout); + g_object_unref(layout); } @@ -136,34 +216,78 @@ static gboolean draw_sig(GtkWidget *widget, cairo_t *cr, struct fixture_display PangoContext *pc; PangoFontDescription *fontdesc; double x, y; + char tmp[128]; w = gtk_widget_get_allocated_width(widget); h = gtk_widget_get_allocated_height(widget); pc = gtk_widget_get_pango_context(widget); + fontdesc = pango_font_description_from_string("Sans 10"); /* Overall background */ - cairo_set_source_rgb(cr, 0.0, 0.0, 0.2); - cairo_paint(cr); + if ( fixd->repl == NULL ) { + cairo_set_source_rgb(cr, 0.2, 0.0, 0.0); + cairo_paint(cr); + return FALSE; + } else { + cairo_set_source_rgb(cr, 0.0, 0.0, 0.08); + cairo_paint(cr); + } cairo_save(cr); cairo_translate(cr, OVERALL_BORDER, OVERALL_BORDER); w -= OVERALL_BORDER*2.0; h -= OVERALL_BORDER*2.0; + /* Playback status */ + cairo_save(cr); + + if ( fixd->cue_running ) { + cairo_rectangle(cr, 0.0, 0.0, w, 18.0); + cairo_set_source_rgb(cr, 0.5, 0.0, 0.0); + cairo_fill(cr); + } + + if ( fixd->current_cue_number < 0.0 ) { + snprintf(tmp, 128, "Playback %s: Current cue doesn't exist! " + "Scanout %.2f per second", + fixd->playback_name, + fixd->scanout_rate); + } else { + snprintf(tmp, 128, "Playback %s: Current cue number: %.2f " + "Scanout %.2f per second", + fixd->playback_name, + fixd->current_cue_number, + fixd->scanout_rate); + } + plot_text(cr, tmp, pc, fontdesc, 0.0, 0.0); + cairo_restore(cr); + + if ( !fixd->programmer_empty ) { + cairo_rectangle(cr, w-150.0, 0.0, 150.0, 18.0); + cairo_set_source_rgb(cr, 0.8, 0.0, 0.0); + cairo_fill(cr); + plot_text(cr, "Programmer active", pc, fontdesc, w-150.0, 0.0); + } + /* Fixtures */ - x = FIXTURE_BORDER; - y = FIXTURE_BORDER; - fontdesc = pango_font_description_from_string("Comfortaa Bold 8"); + x = 0.0; + y = STATUS_HEIGHT; for ( i=0; i<fixd->n_fixtures; i++ ) { + double fw, fh; cairo_save(cr); cairo_translate(cr, x, y); - cairo_scale(cr, fixd->fixture_tile_width/40.0, fixd->fixture_tile_width/40.0); - draw_fixture(cr, pc, fontdesc, fixd, &fixd->fixtures[i]); + draw_fixture(cr, pc, fontdesc, fixd, &fixd->fixtures[i], + &fw, &fh); + fixd->fixtures[i].min_x = x; + fixd->fixtures[i].min_y = y; + fixd->fixtures[i].max_x = x + fw; + fixd->fixtures[i].max_y = y + fh; cairo_restore(cr); - x += fixd->fixture_tile_width + FIXTURE_BORDER*2; - if ( x + fixd->fixture_tile_width + FIXTURE_BORDER*2 > w ) { - x = FIXTURE_BORDER; - y += fixd->fixture_tile_width*3.0/2.0 + FIXTURE_BORDER*2; + x += fw + FIXTURE_BORDER; + if ( x + fw > w) { + /* Can't fit another fixture on this row */ + x = 0.0; + y += fh + FIXTURE_BORDER; } } @@ -184,32 +308,59 @@ static void redraw(struct fixture_display *fixd) static void shutdown_sig(GtkWidget *window, struct fixture_display *fixd) { - repl_connection_close(fixd->repl); + if ( fixd->repl != NULL ) { + repl_connection_close(fixd->repl); + } fixd->shutdown = TRUE; } +static void request_programmer_status(struct fixture_display *fixd) +{ + char tmp[256]; + snprintf(tmp, 256, "(list 'programmer-empty " + "(state-empty? programmer-state))"); + repl_send(fixd->repl, tmp); +} + + +static void request_playback_status(struct fixture_display *fixd) +{ + char tmp[256]; + snprintf(tmp, 256, "(list 'playback-status (list " + "(get-playback-cue-number %s)" + "scanout-freq" + "(playback-state %s)" + "))", + fixd->playback_name, + fixd->playback_name); + repl_send(fixd->repl, tmp); +} + + static void request_intensities(struct fixture_display *fixd) { int i; + repl_send(fixd->repl, "(define all-vals (current-value-state))\n"); for ( i=0; i<fixd->n_fixtures; i++ ) { char tmp[256]; - snprintf(tmp, 256, "(list 'fixture-intensity (list \"%s\" " - "(current-value %s 'intensity)))", + snprintf(tmp, 256, "(list" + " 'fixture-parameters" + " (list \"%s\" " + " (state-find %s intensity all-vals) " + " (let ((col (state-find %s colour all-vals)))" + " (if (colour? col)" + " (colour-as-rgb col)" + " #f))))", fixd->fixtures[i].label, + fixd->fixtures[i].scheme_name, fixd->fixtures[i].scheme_name); repl_send(fixd->repl, tmp); } } -static void request_selection(struct fixture_display *fixd) -{ - repl_send(fixd->repl, "(list 'selection (map get-fixture-name (get-selection)))"); -} - - static gboolean key_press_sig(GtkWidget *da, GdkEventKey *event, struct fixture_display *fixd) { int claim = 1; @@ -228,6 +379,10 @@ static gboolean key_press_sig(GtkWidget *da, GdkEventKey *event, struct fixture_ repl_send(fixd->repl, "(back! pb)"); break; + case GDK_KEY_F5 : + repl_send(fixd->repl, "(exit)"); + break; + default : claim = 0; break; @@ -254,13 +409,28 @@ static gint realise_sig(GtkWidget *da, struct fixture_display *fixd) static gboolean redraw_cb(gpointer data) { struct fixture_display *fixd = data; + if ( fixd->repl == NULL ) { + return G_SOURCE_CONTINUE; + } if ( repl_closed(fixd->repl) ) { - gtk_main_quit(); - return G_SOURCE_REMOVE; + if ( fixd->shutdown ) { + gtk_main_quit(); + return G_SOURCE_REMOVE; + } else { + fixd->repl = NULL; + free(fixd->fixtures); + fixd->fixtures = NULL; + fixd->n_fixtures = 0; + redraw(fixd); + return G_SOURCE_CONTINUE; + } } else { - if ( !fixd->shutdown ) { + if ( !fixd->shutdown && fixd->got_eof ) { + fixd->got_eof = FALSE; request_intensities(fixd); - request_selection(fixd); + request_playback_status(fixd); + request_programmer_status(fixd); + repl_send(fixd->repl, "'end-of-stuff"); redraw(fixd); } return G_SOURCE_CONTINUE; @@ -303,17 +473,6 @@ static int symbol_eq(SCM symbol, const char *val) } -static char *symbol_to_str(SCM symbol) -{ - if ( scm_is_symbol(symbol) ) { - SCM str = scm_symbol_to_string(symbol); - return scm_to_locale_string(str); - } else { - return NULL; - } -} - - static char *group_fixture_name(SCM item) { char tmp[64]; @@ -367,17 +526,43 @@ static void handle_patched_fixtures(struct fixture_display *fixd, fixd->fixtures[i].intensity = -1; fixd->fixtures[i].selected = 0; + fixd->fixtures[i].min_x = 0.0; + fixd->fixtures[i].min_y = 0.0; + fixd->fixtures[i].max_x = 0.0; + fixd->fixtures[i].max_y = 0.0; + fixd->fixtures[i].intensity = 0.0; + fixd->fixtures[i].rgb[0] = 0.0; + fixd->fixtures[i].rgb[1] = 0.0; + fixd->fixtures[i].rgb[2] = 0.0; + } +} + + +static void read_rgb(double *rgb, SCM rgb_obj) +{ + if ( scm_is_false(rgb_obj) ) { + rgb[0] = 1.0; + rgb[1] = 1.0; + rgb[2] = 1.0; + } else { + if ( is_list(rgb_obj) ) { + rgb[0] = scm_to_double(scm_list_ref(rgb_obj, scm_from_int(0)))/100.0; + rgb[1] = scm_to_double(scm_list_ref(rgb_obj, scm_from_int(1)))/100.0; + rgb[2] = scm_to_double(scm_list_ref(rgb_obj, scm_from_int(2)))/100.0; + } else { + fprintf(stderr, "Colour isn't a list\n"); + } } } -static void handle_fixture_intensity(struct fixture_display *fixd, SCM list) +static void handle_fixture_parameters(struct fixture_display *fixd, SCM list) { char *fixture_name; struct fixture *fix; - if ( !is_list(list) || (scm_to_int(scm_length(list)) != 2) ) { - fprintf(stderr, "Invalid fixture intensity\n"); + if ( !is_list(list) || (scm_to_int(scm_length(list)) != 3) ) { + fprintf(stderr, "Invalid fixture parameters\n"); return; } @@ -385,9 +570,15 @@ static void handle_fixture_intensity(struct fixture_display *fixd, SCM list) fix = find_fixture(fixd, fixture_name); if ( fix != NULL ) { - fix->intensity = scm_to_double(scm_list_ref(list, scm_from_int(1))); + SCM i = scm_list_ref(list, scm_from_int(1)); + if ( symbol_eq(i, "no-value") ) { + fix->intensity = 0.0; + } else { + fix->intensity = scm_to_double(i); + } + read_rgb(fix->rgb, scm_list_ref(list, scm_from_int(2))); } else { - fprintf(stderr, "Unrecognised fixture '%s' (intensity)\n", + fprintf(stderr, "Unrecognised fixture '%s' (parameters)\n", fixture_name); } @@ -395,45 +586,23 @@ static void handle_fixture_intensity(struct fixture_display *fixd, SCM list) } -static void handle_selection(struct fixture_display *fixd, SCM list) +static void handle_playback_status(struct fixture_display *fixd, SCM list) { - int i; - int nfix; - - if ( !is_list(list) ) { - fprintf(stderr, "Invalid selection list\n"); - return; - } - - nfix = scm_to_int(scm_length(list)); - - for ( i=0; i<fixd->n_fixtures; i++ ) { - fixd->fixtures[i].selected = 0; + SCM cue_number = scm_list_ref(list, scm_from_int(0)); + if ( scm_is_false(cue_number) ) { + fixd->current_cue_number = -1.0; + } else { + fixd->current_cue_number = scm_to_double(cue_number); } + fixd->scanout_rate = scm_to_double(scm_list_ref(list, scm_from_int(1))); + fixd->cue_running = symbol_eq(scm_list_ref(list, scm_from_int(2)), + "running"); +} - for ( i=0; i<nfix; i++ ) { - SCM item = scm_list_ref(list, scm_from_int(i)); - char *name_str; - if ( scm_is_symbol(item) ) { - name_str = symbol_to_str(item); - } else if ( is_list(item) ) { - name_str = group_fixture_name(item); - } else { - fprintf(stderr, "Unrecognised type in selection list\n"); - name_str = NULL; - } - if ( name_str != NULL ) { - struct fixture *fix = find_fixture(fixd, name_str); - if ( fix != NULL ) { - fix->selected = 1; - } else { - fprintf(stderr, "Fixture '%s' not found (selection)\n", - name_str); - } - free(name_str); - } - } +static void handle_programmer_status(struct fixture_display *fixd, SCM empty) +{ + fixd->programmer_empty = scm_is_true(empty); } @@ -447,13 +616,99 @@ static void process_line(SCM sexp, void *data) if ( scm_is_symbol(tag) ) { if ( symbol_eq(tag, "patched-fixtures") ) { handle_patched_fixtures(fixd, contents); - } else if ( symbol_eq(tag, "fixture-intensity") ) { - handle_fixture_intensity(fixd, contents); - } else if ( symbol_eq(tag, "selection") ) { - handle_selection(fixd, contents); + } else if ( symbol_eq(tag, "fixture-parameters") ) { + handle_fixture_parameters(fixd, contents); + } else if ( symbol_eq(tag, "playback-status") ) { + handle_playback_status(fixd, contents); + } else if ( symbol_eq(tag, "programmer-empty") ) { + handle_programmer_status(fixd, contents); } } + } else if ( scm_is_symbol(sexp) && symbol_eq(sexp, "end-of-stuff") ) { + fixd->got_eof = TRUE; + } +} + + +static gboolean try_connect_cb(gpointer data) +{ + struct fixture_display *fixd = data; + if ( fixd->repl == NULL ) { + fixd->repl = repl_connection_new(fixd->socket, process_line, + fixd, fixd->verbose); + if ( fixd->repl != NULL ) { + fixd->got_eof = FALSE; + repl_send(fixd->repl, "(list 'patched-fixtures (reverse (patched-fixture-names)))"); + repl_send(fixd->repl, "'end-of-stuff"); + } } + return G_SOURCE_CONTINUE; +} + + +static struct fixture *which_fixture(struct fixture_display *fixd, + double x, double y) +{ + int i; + for ( i=0; i<fixd->n_fixtures; i++ ) { + struct fixture *t = &fixd->fixtures[i]; + if ( (x > t->min_x) + && (x < t->max_x) + && (y > t->min_y) + && (y < t->max_y) ) return t; + } + return NULL; +} + + +static gint button_press_sig(GtkWidget *window, GdkEventButton *event, + struct fixture_display *fixd) +{ + struct fixture *fix; + if ( event->y < STATUS_HEIGHT ) return FALSE; + fix = which_fixture(fixd, + event->x-OVERALL_BORDER, + event->y-OVERALL_BORDER); + if ( fix != NULL ) { + char tmp[256]; + snprintf(tmp, 256, "(toggle-sel %s)", fix->scheme_name); + repl_send(fixd->repl, tmp); + } + return FALSE; +} + + +static void osc_error_callback(int num, const char *msg, const char *path) +{ + fprintf(stderr, "liblo error %i (%s) for path %s\n", num, msg, path); +} + + +static int osc_selection_callback(const char *path, const char *types, + lo_arg **argv, int argc, lo_message msg, + void *vp) +{ + int i; + gchar **bits; + struct fixture_display *fixd = vp; + + for ( i=0; i<fixd->n_fixtures; i++ ) { + fixd->fixtures[i].selected = 0; + } + + bits = g_strsplit(&argv[0]->s, " ",-1); + for ( i=0; bits[i] != NULL; i++ ) { + struct fixture *fix = find_fixture(fixd, bits[i]); + if ( fix != NULL ) { + fix->selected = 1; + } else { + fprintf(stderr, "Fixture '%s' not found (selection)\n", + bits[i]); + } + } + g_strfreev(bits); + + return 1; } @@ -520,29 +775,41 @@ int main(int argc, char *argv[]) da = gtk_drawing_area_new(); - fixd.fixture_tile_width = 60.0; fixd.fixtures = NULL; fixd.n_fixtures = 0; fixd.da = da; fixd.shutdown = FALSE; + fixd.socket = socket; + fixd.verbose = verbose; + fixd.repl = NULL; + fixd.playback_name = strdup("pb"); + fixd.cue_running = 0; + fixd.programmer_empty = 1; + fixd.got_eof = TRUE; + + fixd.osc_srv = lo_server_thread_new_from_url("osc.udp://:7772", + osc_error_callback); + lo_server_thread_start(fixd.osc_srv); + lo_server_thread_add_method(fixd.osc_srv, "/starlet/selection/update", + "s", osc_selection_callback, &fixd); gtk_container_add(GTK_CONTAINER(mainwindow), GTK_WIDGET(da)); gtk_widget_set_can_focus(GTK_WIDGET(da), TRUE); gtk_widget_add_events(da, GDK_KEY_PRESS_MASK | GDK_KEY_RELEASE_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK | GDK_BUTTON_MOTION_MASK); - g_signal_connect(G_OBJECT(da), "draw", G_CALLBACK(draw_sig), &fixd); - g_signal_connect(G_OBJECT(da), "realize", G_CALLBACK(realise_sig), &fixd); + g_signal_connect(G_OBJECT(da), + "draw", G_CALLBACK(draw_sig), &fixd); + g_signal_connect(G_OBJECT(da), "realize", + G_CALLBACK(realise_sig), &fixd); + g_signal_connect(G_OBJECT(da), "button-press-event", + G_CALLBACK(button_press_sig), &fixd); gtk_widget_grab_focus(GTK_WIDGET(da)); gtk_widget_show_all(mainwindow); - g_timeout_add(50, redraw_cb, &fixd); - - fixd.repl = repl_connection_new(socket, process_line, &fixd, verbose); - if ( fixd.repl == NULL ) return 1; - - repl_send(fixd.repl, "(list 'patched-fixtures (patched-fixture-names))"); + g_timeout_add(200, redraw_cb, &fixd); + g_timeout_add(1000, try_connect_cb, &fixd); gtk_main(); |
