coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cinema model (events core): Cinema/Screen/Calendar/Film/Showing/Offering + /cinema admin

Browse Source 
The Rose Ash Cinema object model, operable on events.rose-ash.com/cinema.

- host/blog-seed-cinema!: seeds the type-posts (cinema/screen/calendar/film/ticket-type/showing/
  offering) + Rose Ash Cinema with two screens (each capacity 100 + a calendar) + ticket types
  (adult/u18/concession/standing). Idempotent. Called from serve.sh's events block.
- /cinema page: screens (with capacity) → their calendars → showings; a Films list (each with its
  ticket types); an Add-film form; a Book-a-showing form.
- host/blog-new-film: creates a film is-a film + default ticket types (adult, u18).
- host/blog-new-showing: books a Film onto a Calendar at a time (showing of-film / on-calendar,
  calendar --scheduled--> showing), with an optional per-showing capacity override, and SNAPSHOTS
  the film's ticket types as Offerings (offering of-type, showing --offers--> offering, price field).
- Views: host/blog--screens-view / --calendar-view / --films-view (all via out-raw for federated refs).

LIVE: events.rose-ash.com/cinema shows the two screens + calendars; add 'Dune' → film with adult/u18;
book Dune on cal-screen-1 Fri 8pm → a showing with offerings, listed under the calendar. blog 218/218.

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
giles
2026-07-03 07:56:30 +00:00
parent 12b4e15569
commit 7aaf2c9b17
2 changed files with 119 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

115
lib/host/blog.sx
View File

@@ -3045,6 +3045,118 @@
(host/blog-relate! oid "order" "is-a")
(host/blog-relate! oid event "for")
(dream-response 200 {:content-type "text/plain; charset=utf-8"} (str "order:" oid)))))))
;; ── the CINEMA model (events domain): Cinema → Screen → Calendar, Film, TicketType, Showing, Offering ──
;; Seed the type-posts + Rose Ash Cinema with two screens (each with a default capacity + a calendar)
;; + a set of ticket types. Idempotent (seed!/relate! are sets).
(define host/blog-seed-cinema!
(fn ()
(begin
(for-each (fn (t) (host/blog-seed! t t (str "(article (h1 \"" t "\"))") "published"))
(list "cinema" "screen" "calendar" "film" "ticket-type" "showing" "offering"))
(host/blog-seed! "rose-ash-cinema" "Rose Ash Cinema" "(article (h1 \"Rose Ash Cinema\"))" "published")
(host/blog-relate! "rose-ash-cinema" "cinema" "is-a")
(for-each (fn (n)
(let ((scr (str "screen-" n)) (cal (str "cal-screen-" n)))
(begin
(host/blog-seed! scr (str "Screen " n) (str "(article (h1 \"Screen " n "\"))") "published")
(host/blog-relate! scr "screen" "is-a")
(host/blog-relate! "rose-ash-cinema" scr "has-screen")
(host/blog--set-field-values! scr {"capacity" "100"})
(host/blog-seed! cal (str "Screen " n " Calendar") "(article (h1 \"Calendar\"))" "published")
(host/blog-relate! cal "calendar" "is-a")
(host/blog-relate! scr cal "has-calendar"))))
(list "1" "2"))
(for-each (fn (tt) (begin (host/blog-seed! tt tt (str "(article (h1 \"" tt "\"))") "published")
(host/blog-relate! tt "ticket-type" "is-a")))
(list "adult" "u18" "concession" "standing")))))
;; the showings scheduled on a calendar (calendar --scheduled--> showing).
(define host/blog--calendar-view
(fn (cal)
(let ((showings (host/blog--out-raw cal "scheduled")))
(quasiquote (div :style "margin:0.2em 0 0.2em 1em;font-size:0.9em"
(i (unquote (str cal))) ": "
(unquote (if (= (len showings) 0) (quote (span :style "color:#999" "no showings"))
(cons (quote span) (map (fn (s) (quasiquote (span (a :href (unquote (str "/" s "/")) (unquote (str s))) " "))) showings)))))))))
;; the cinema's screens (with capacity) + each screen's calendar + its showings.
(define host/blog--screens-view
(fn (cinema)
(cons (quote div)
(map (fn (scr)
(let ((cap (get (host/blog-field-values-of scr) "capacity")) (cals (host/blog--out-raw scr "has-calendar")))
(quasiquote (div :style "margin:0.4em 0;padding:0.4em 0.6em;border:1px solid #ddd;border-radius:4px"
(b (unquote (str scr))) (unquote (str " · capacity " (or cap "?")))
(unquote (cons (quote div) (map host/blog--calendar-view cals)))))))
(host/blog--out-raw cinema "has-screen")))))
;; the films + their default ticket types.
(define host/blog--films-view
(fn ()
(let ((films (host/blog-in "film" "is-a")))
(if (= (len films) 0) (quote (p :style "color:#999" (em "No films yet.")))
(cons (quote ul)
(map (fn (f) (quasiquote (li (b (unquote (str f)))
(unquote (str " · ticket types: " (join ", " (host/blog--out-raw f "has-ticket-type")))))))
films))))))
;; add a film (+ its default ticket types: adult, u18).
(define host/blog-new-film
(fn (req)
(let ((title (host/field req "title")))
(begin
(when (and title (not (= title "")))
(let ((slug (host/blog-slugify title)))
(begin
(host/blog-seed! slug title (str "(article (h1 \"" title "\"))") "published")
(host/blog-relate! slug "film" "is-a")
(for-each (fn (tt) (host/blog-relate! slug tt "has-ticket-type")) (list "adult" "u18")))))
(dream-redirect "/cinema")))))
;; book a showing: a Film onto a Calendar at a time; snapshot the film's ticket types as Offerings.
(define host/blog-new-showing
(fn (req)
(let ((film (host/field req "film")) (calendar (host/field req "calendar"))
(time (or (host/field req "time") "")) (cap (or (host/field req "capacity") "")))
(begin
(when (and film (not (= film "")) calendar (not (= calendar "")))
(let ((slug (host/blog-slugify (str film "-" calendar "-" time))))
(begin
(host/blog-seed! slug (str film " showing") (str "(article (h1 \"Showing: " film "\") (p \"" time "\"))") "published")
(host/blog-relate! slug "showing" "is-a")
(host/blog-relate! slug film "of-film")
(host/blog-relate! calendar slug "scheduled")
(host/blog-relate! slug calendar "on-calendar")
(host/blog--set-field-values! slug {"time" time "capacity" cap})
(for-each (fn (tt)
(let ((off (str slug "--" tt)))
(begin
(host/blog-seed! off (str tt " @ " slug) "(article (h1 \"Offering\"))" "published")
(host/blog-relate! off "offering" "is-a")
(host/blog-relate! slug off "offers")
(host/blog-relate! off tt "of-type")
(host/blog--set-field-values! off {"price" "10"}))))
(host/blog--out-raw film "has-ticket-type")))))
(dream-redirect "/cinema")))))
;; ── /cinema — the events domain admin: screens/calendars/showings, add a film, book a showing ──
(define host/blog-cinema
(fn (req)
(host/blog--resp req 200
(host/blog--page req "Rose Ash Cinema"
(quasiquote
(div (h1 "🎬 Rose Ash Cinema")
(h3 :style "margin:0.8em 0 0.2em" "Screens & calendars")
(unquote (host/blog--screens-view "rose-ash-cinema"))
(h3 :style "margin:0.8em 0 0.2em" "Films")
(unquote (host/blog--films-view))
(form :method "post" :action "/new-film" :style "margin:0.4em 0"
(input :name "title" :placeholder "Film title") " " (button :type "submit" "Add film"))
(h3 :style "margin:0.8em 0 0.2em" "Book a showing")
(form :method "post" :action "/new-showing"
:style "padding:0.5em;border:1px dashed #bbb;background:#fafafa;font-size:0.9em"
(input :name "film" :placeholder "film slug" :style "width:9em") " "
(input :name "calendar" :placeholder "cal-screen-1" :style "width:9em") " "
(input :name "time" :placeholder "Fri 8pm" :style "width:7em") " "
(input :name "capacity" :placeholder "cap (opt)" :style "width:6em") " "
(button :type "submit" "Book showing"))))))))
;; ── /orders — the shop domain view: ticket orders placed for events (federated from events) ──
(define host/blog-orders
(fn (req)
@@ -3141,7 +3253,10 @@
(dream-get "/flows" host/blog-flows)
(dream-get "/fed-tick" host/blog-fed-tick)
(dream-get "/calendars" host/blog-calendars)
(dream-get "/cinema" host/blog-cinema)
(dream-get "/orders" host/blog-orders)
(dream-post "/new-film" host/blog-new-film)
(dream-post "/new-showing" host/blog-new-showing)
(dream-post "/new-event" host/blog-new-event)
(dream-post "/buy" host/blog-buy)
(dream-post "/order" host/blog-order)