Merge branch 'rich-text-protocol'

* rich-text-protocol: combine images and text for monster abilities rich-text-display: fix scrolling for picts rich-text-display: extract model
benknoble · Feb 5, 2024 · 9785df2 · 9785df2
2 parents 8e6da62 + d283be6
commit 9785df2
Show file tree

Hide file tree

Showing 6 changed files with 163 additions and 148 deletions.
diff --git a/defns/monsters.rkt b/defns/monsters.rkt
@@ -36,10 +36,9 @@
   [monster-stats-immunities-string (-> monster-stats? string?)]
   [monster-ability-name->text (-> (or/c #f monster-ability?) string?)]
   [monster-ability-initiative->text (-> (or/c #f monster-ability?) string?)]
-  [monster-ability-ability->text (-> string? (-> monster-group? env/c string?))]
-  [monster-ability-ability->extras (-> (or/c #f monster-ability?)
-                                       string?
-                                       (listof (or/c (list/c 'aoe-pict pict:pict?))))]
+  [monster-ability-ability->rich-text (-> string? (or/c #f monster-ability?)
+                                          monster-group? env/c
+                                          (listof (or/c string? pict:pict? pict/alt-text? newline?)))]
   [make-monster (-> monster-info? level/c
                     monster-number/c boolean?
                     env/c
@@ -77,7 +76,8 @@
  frosthaven-manager/qi
  frosthaven-manager/parsers/formula
  frosthaven-manager/defns/level
- frosthaven-manager/defns/scenario)
+ frosthaven-manager/defns/scenario
+ (submod frosthaven-manager/gui/rich-text-display model))
 
 (struct monster-stats [max-hp move attack bonuses effects immunities] #:prefab)
 (struct monster-info [set-name name normal-stats elite-stats] #:prefab)
@@ -129,24 +129,7 @@
 (define-flow (monster-ability-initiative->text ability)
   (if monster-ability? (~> monster-ability-initiative ~a) "??"))
 
-(define aoe-rx #rx"aoe\\(([^)]+)\\)")
-
-(define ((keyword-sub stats-f mg) _match word +- amount)
-  (define op (eval (string->symbol +-) (make-base-namespace)))
-  (define amount* (string->number amount))
-  (define normal-base (stats-f (monster-group-normal-stats mg)))
-  (define elite-base (stats-f (monster-group-elite-stats mg)))
-  (define normal (if normal-base (op normal-base amount*) "-"))
-  (define elite (if elite-base (op elite-base amount*) "-"))
-  (format "~a ~a (E:~a)" word normal elite))
-
-(define ((skip-if-grant-or-control f) match before . args)
-  (if (regexp-match #px"(?i:grant)|(?i:control)" before)
-    match
-    (format "~a~a" before (apply f (substring match (string-length before)) args))))
-
-(define ((monster-ability-ability->text ability) mg env)
-  (define aoe-replacement `(,aoe-rx ""))
+(define (monster-ability-ability->rich-text ability-text ability-card mg env)
   (define bulleted '(#rx"^" "· "))
   (define attack
     (list #px"(.*)((?i:attack))\\s+([+-])(\\d+)"
@@ -165,7 +148,6 @@
              (define common-effects (set-intersect effects elite-effects))
              (define only-normal-effects (set-subtract effects common-effects))
              (define only-elite-effects (set-subtract elite-effects common-effects))
-
              (~a base-attack
                  (if (not (empty? only-normal-effects))
                    (format " (N:~a)" (string-join only-normal-effects ", "))
@@ -178,11 +160,24 @@
                    ""))))))
   (define replacements
     (list bulleted
-          aoe-replacement
           attack
           effects
           move))
-  (regexp-replaces ability replacements))
+  (match (regexp-replaces ability-text replacements)
+    [(regexp #rx"^(.*)aoe\\(([^)]+)\\)(.*)$"
+             (list _ prefix aoe suffix))
+     (define base
+       (switch (ability-card)
+         [monster-ability? monster-ability-location]
+         [else "."]))
+     (define aoe-pict
+       (~> (base aoe)
+           build-path
+           (switch
+             [file-exists? (~> get-aoe apply)]
+             [else (gen (pict:text "AoE File Not Found"))])))
+     (list prefix newline aoe-pict newline suffix)]
+    [x (list x)]))
 
 (module+ test
   (require rackunit)
@@ -196,36 +191,53 @@
                                  empty
                                  env))
            (list 0 1 2 3))))
+  (define ability-card
+    (match-let-values ([{_ ability} (get-dbs  "../testfiles/sample-bestiary-import.rkt")])
+      (~> (ability) (hash-ref "archer") first)))
   (test-equal? "Simple Attack"
-               ((monster-ability-ability->text "Attack +1") mg env)
-               "· Attack 3 (E:4, wound)")
+               (monster-ability-ability->rich-text "Attack +1" ability-card mg env)
+               (list "· Attack 3 (E:4, wound)"))
   (test-equal? "Simple Attack 1"
-               ((monster-ability-ability->text "Attack +1") mg1 env)
-               "· Attack 4 (E:5), wound")
+               (monster-ability-ability->rich-text "Attack +1" ability-card mg1 env)
+               (list "· Attack 4 (E:5), wound"))
   (test-equal? "Simple Attack 2"
-               ((monster-ability-ability->text "Attack +1") mg2 env)
-               "· Attack 5 (E:6, stun), wound")
+               (monster-ability-ability->rich-text "Attack +1" ability-card mg2 env)
+               (list "· Attack 5 (E:6, stun), wound"))
   (test-equal? "Simple Attack 3"
-               ((monster-ability-ability->text "Attack +1") mg3 env)
-               "· Attack 6 (N:muddle) (E:7, stun), wound")
+               (monster-ability-ability->rich-text "Attack +1" ability-card mg3 env)
+               (list "· Attack 6 (N:muddle) (E:7, stun), wound"))
   (test-equal? "Attack, X"
-               ((monster-ability-ability->text "Attack +1, Push 1") mg3 env)
-               "· Attack 6 (N:muddle) (E:7, stun), wound, Push 1")
+               (monster-ability-ability->rich-text "Attack +1, Push 1" ability-card mg3 env)
+               (list "· Attack 6 (N:muddle) (E:7, stun), wound, Push 1"))
   (test-equal? "Simple Move"
-               ((monster-ability-ability->text "Move +1") mg env)
-               "· Move 3 (E:3)")
+               (monster-ability-ability->rich-text "Move +1" ability-card mg env)
+               (list "· Move 3 (E:3)"))
   (test-equal? "Granted Attack"
-               ((monster-ability-ability->text "Grant Piranha: Attack +1") mg env)
-               "· Grant Piranha: Attack +1")
+               (monster-ability-ability->rich-text "Grant Piranha: Attack +1" ability-card mg env)
+               (list "· Grant Piranha: Attack +1"))
   (test-equal? "Granted Move"
-               ((monster-ability-ability->text "Grant Piranha: Move +1") mg env)
-               "· Grant Piranha: Move +1")
+               (monster-ability-ability->rich-text "Grant Piranha: Move +1" ability-card mg env)
+               (list "· Grant Piranha: Move +1"))
   (test-equal? "Controlled Attack"
-               ((monster-ability-ability->text "Control Enemy: Attack +1") mg env)
-               "· Control Enemy: Attack +1")
+               (monster-ability-ability->rich-text "Control Enemy: Attack +1" ability-card mg env)
+               (list "· Control Enemy: Attack +1"))
   (test-equal? "Controlled Move"
-               ((monster-ability-ability->text "Control Enemy: Move +1") mg env)
-               "· Control Enemy: Move +1"))
+               (monster-ability-ability->rich-text "Control Enemy: Move +1" ability-card mg env)
+               (list "· Control Enemy: Move +1")))
+
+(define ((keyword-sub stats-f mg) _match word +- amount)
+  (define op (eval (string->symbol +-) (make-base-namespace)))
+  (define amount* (string->number amount))
+  (define normal-base (stats-f (monster-group-normal-stats mg)))
+  (define elite-base (stats-f (monster-group-elite-stats mg)))
+  (define normal (if normal-base (op normal-base amount*) "-"))
+  (define elite (if elite-base (op elite-base amount*) "-"))
+  (format "~a ~a (E:~a)" word normal elite))
+
+(define ((skip-if-grant-or-control f) match before . args)
+  (if (regexp-match #px"(?i:grant)|(?i:control)" before)
+    match
+    (format "~a~a" before (apply f (substring match (string-length before)) args))))
 
 (define (not-an-aoe)
   (pict:text "Not an AoE module"))
@@ -236,21 +248,6 @@
    (thunk
     (dynamic-require path 'aoe (thunk not-an-aoe)))))
 
-(define (monster-ability-ability->extras ability-card ability-text)
-  (define aoe
-    (~> (ability-text) (regexp-match aoe-rx _) (and _ second)))
-  (define base (switch (ability-card)
-                 [monster-ability? monster-ability-location]
-                 [else "."]))
-  (define aoe-pict
-    (and aoe (~> (base aoe)
-                 build-path
-                 (switch
-                   [file-exists? (~> get-aoe apply)]
-                   [else (gen (pict:text "AoE File Not Found"))]))))
-  (filter values
-          (list (and aoe-pict `(aoe-pict ,aoe-pict)))))
-
 (define (make-monster* stats number elite? env)
   (monster number elite? (monster-stats-max-hp* stats env) empty))
 

diff --git a/gui/monsters.rkt b/gui/monsters.rkt
@@ -304,28 +304,21 @@
                     (monsters))])))
 
 (define (monster-ability-view @ability @mg @env)
-  (hpanel
-   (rich-text-display
-    (obs-combine
-     (λ (ability mg env)
-       (if ability
-         (list*
-          (monster-ability-name->text ability) " (" (monster-ability-initiative->text ability) ")" newline
-          (~> (ability)
-              (if _ monster-ability-abilities '())
-              (sep (-< (~> (-< monster-ability-ability->text (gen mg) (gen env)) apply)
-                       (gen newline)))
-              collect
-              (dropf-right newline?)))
-         (list "???")))
-     @ability @mg @env)
-    #:min-size '(200 60))
-   (observable-view
-    @ability
-    (λ (ability)
-      (apply vpanel
-             (for/list ([ability-text (if ability (monster-ability-abilities ability) empty)])
-               (ability->extras @mg @ability ability-text)))))))
+  (rich-text-display
+   (obs-combine
+    (λ (ability mg env)
+      (if ability
+        (list*
+         (monster-ability-name->text ability) " (" (monster-ability-initiative->text ability) ")" newline
+         (~> (ability)
+             (if _ monster-ability-abilities '())
+             (sep (-< (~> (monster-ability-ability->rich-text ability mg env) sep)
+                      (gen newline)))
+             collect
+             (dropf-right newline?)))
+        (list "???")))
+    @ability @mg @env)
+   #:min-size '(200 60)))
 
 ;; TODO: should be able to manipulate individual HP (? dialog with counter)
 ;; Takes a non-observable info-db b/c instantiated by a thunk in
@@ -644,17 +637,6 @@
                                (>< exact-ceiling) list)
                     (pict-canvas pict values)))))))
 
-(define (ability->extras @mg @ability-card ability-text)
-  (define @extras
-    (@~> @ability-card (monster-ability-ability->extras ability-text)))
-  (observable-view
-   @extras
-   (λ (extras)
-     (apply hpanel
-            (for/list ([extra extras])
-              (match extra
-                [(list 'aoe-pict pict) (aoe-button pict)]))))))
-
 (define (ability-deck-preview @ability-deck @mg @env #:on-move [on-move void])
   (define (make-discard-rows ability-deck)
     (for/vector ([ability (ability-decks-discard ability-deck)])

diff --git a/gui/rich-text-display.rkt b/gui/rich-text-display.rkt
@@ -1,11 +1,8 @@
 #lang racket
 
 (provide
+ (all-from-out 'model)
  (contract-out
-  [pict/alt-text? (-> any/c boolean?)]
-  [pict/alt-text (-> pict:pict? string? pict/alt-text?)]
-  [newline? (-> any/c boolean?)]
-  [newline newline?]
   [rich-text-display
    (->* ((maybe-obs/c (listof (or/c string?
                                     pict:pict?
@@ -23,14 +20,42 @@
                                    'resize-corner 'deleted 'transparent)))
         (is-a?/c view<%>))]))
 
-(require racket/gui
+(require (except-in racket/gui newline)
          racket/gui/easy
          racket/gui/easy/contract
          racket/gui/easy/observable
          pict/snip
          (prefix-in pict: pict)
          frosthaven-manager/gui/mixins)
 
+(module model racket
+  (provide
+   (contract-out
+    [struct pict/alt-text ([p pict?]
+                           [alt-text string?])]
+    [newline? (-> any/c boolean?)]
+    [newline newline?]
+    [scale-icon (-> pict? pict?)]))
+
+  (require racket/snip
+           pict)
+
+  (define newline
+    (let ([s (make-object string-snip% "\n")])
+      (begin0 s
+        (send s set-flags (cons 'hard-newline (send s get-flags))))))
+
+  (define (newline? x)
+    (eq? x newline))
+
+  (struct pict/alt-text [p alt-text])
+
+  (define icon-sizer (text "MM\nMM"))
+  (define (scale-icon p)
+    (scale-to-fit p icon-sizer)))
+
+(require 'model)
+
 (define (peek v)
   (if (obs? v)
     (obs-peek v)
@@ -57,16 +82,6 @@
          (set-delta 'change-smoothing smoothing))
   d)
 
-(define newline
-  (let ([s (make-object string-snip% "\n")])
-    (begin0 s
-      (send s set-flags (cons 'hard-newline (send s get-flags))))))
-
-(define (newline? x)
-  (eq? x newline))
-
-(struct pict/alt-text [p alt-text] #:transparent)
-
 (define (draw editor content font)
   (send editor begin-edit-sequence)
   (for ([c content])
@@ -84,25 +99,37 @@
   (for ([style (in-list styles)])
     (send editor change-style style start end #f)))
 
-(define icon-sizer
-  (pict:text "MM\nMM" normal-control-font))
+;; pixels per scroll step, can be set 1 for smooth scrolling
+(define ppss 10.0)
+
+(define pict-snip-v2%
+  (class pict-snip%
+    (init)
+    (super-new)
+
+    (define/override (get-num-scroll-steps)
+      (define height (pict:pict-height (send this get-pict)))
+      (exact-ceiling (/ height ppss)))
+
+    (define/override (get-scroll-step-offset offset)
+      (exact-floor (* offset ppss)))
+
+    (define/override (find-scroll-step y)
+      (exact-floor (/ y ppss)))))
 
 (define (insert-pict editor p)
-  (send editor insert (make-object pict-snip% (pict:scale-to-fit p icon-sizer))))
+  (send editor insert (make-object pict-snip-v2% p)))
 
 (define (insert-pict/alt-text editor p alt-text)
-  (send editor insert
-        (make-object pict-snip/alt-text%
-                     alt-text
-                     (pict:scale-to-fit p icon-sizer))))
+  (send editor insert (make-object pict-snip/alt-text% alt-text p)))
 
 (define (insert-newline editor)
   (define s (make-object string-snip% "\n"))
   (send s set-flags (cons 'hard-newline (send s get-flags)))
   (send editor insert s))
 
 (define pict-snip/alt-text%
-  (class pict-snip% (super-new)
+  (class pict-snip-v2% (super-new)
     [init-field alt-text]
     (define/override (copy)
       (make-object string-snip% alt-text))))