worlds/haxima-1.002/ztats-quest-ui.scm

   1 ;; Implements the Quest Log pane of the Ztats UI
   2
   3 (define (zqug-mk) (list nil nil 0 0 0))
   4 (define (zqug-dims! gob dims) (set-car! gob dims))
   5 (define (zqug-dims gob) (list-ref gob 0))
   6 (define (zqug-party! gob kparty) (set-car! (cdr gob) kparty))
   7 (define (zqug-party gob) (list-ref gob 1))
   8 (define (zqug-cur-entry gob) (list-ref gob 2))
   9 (define (zqug-cur-entry! gob val) (list-set-ref! gob 2 val))
  10 (define (zqug-max-entry! gob val) (list-set-ref! gob 3 val))
  11 (define (zqug-max-entry gob) (list-ref gob 3))
  12 (define (zqug-top-entry gob) (list-ref gob 4))
  13 (define (zqug-top-entry! gob val) (list-set-ref! gob 4 val))
  14
  15 (define sprite-offset-x 40)
  16 (define sprite-offset-y (/ (- 32 kern-ascii-h) 2))
  17 (define sprite-lineheight 40)
  18
  19 (define (zqug-store-max-entry! zqug)
  20   (let ((pgob (gob (zqug-party zqug))))
  21     (if (null? pgob)
  22         0
  23         (let ((qlst (tbl-get pgob 'quests)))
  24           (if (null? qlst)
  25               0
  26               (zqug-max-entry! zqug (1- (length qlst)))
  27               )))))
  28
  29 (if use-quest-pane
  30
  31 (kern-ztats-add-pane
  32
  33  ;; enter
  34  (lambda (zqug kparty dir dims)
  35    (kern-status-set-title "Quest Log")
  36    (zqug-dims! zqug dims)
  37    (zqug-party! zqug kparty)
  38    (zqug-store-max-entry! zqug)
  39    )
  40
  41  ;; scroll
  42  (lambda (zqug dir)
  43    (let* ((top (zqug-top-entry zqug))
  44           (cur (zqug-cur-entry zqug))
  45           (max (zqug-max-entry zqug))
  46           (winh (/ (rect-h (zqug-dims zqug)) sprite-lineheight))
  47           (midwin (/ winh 2))
  48           (maxtop (- (1+ max) winh))
  49          )
  50
  51      (define (up n top cur)
  52        (cond ((and (> cur 0) (> n 0))
  53               (if (and (> top 0)
  54                        (< cur (- max midwin)))
  55                   (up (1- n) (1- top) (1- cur))
  56                   (up (1- n) top (1- cur)))
  57               )
  58              (else
  59               (zqug-top-entry! zqug top)
  60               (zqug-cur-entry! zqug cur)
  61               )))
  62
  63      (define (down n top cur)
  64        (cond ((and (< cur max) (> n 0))
  65               (if (and (< top maxtop)
  66                        (>= cur midwin))
  67                   (down (1- n) (1+ top) (1+ cur))
  68                   (down (1- n) top (1+ cur)))
  69               )
  70              (else
  71              (println "down" top " " cur)
  72               (zqug-top-entry! zqug top)
  73               (zqug-cur-entry! zqug cur)
  74               )))
  75
  76      (cond ((= dir scroll-up) (up 1 top cur) #t)
  77            ((= dir scroll-down) (down 1 top cur) #t)
  78            ((= dir scroll-pageup) (up winh top cur) #t)
  79            ((= dir scroll-pagedown) (down winh top cur) #t)
  80            ((= dir scroll-top)
  81             (zqug-top-entry! zqug 0)
  82             (zqug-cur-entry! zqug 0)
  83             #t)
  84            ((= dir scroll-bottom)
  85             (zqug-top-entry! zqug maxtop)
  86             (zqug-cur-entry! zqug max)
  87             #t)
  88            (else #f)
  89            )))
  90
  91  ;; paint
  92  (lambda (zqug)
  93    (let* ((dims (zqug-dims zqug))
  94           (pgob (gob (zqug-party zqug)))
  95           (winh (/ (rect-h dims) kern-ascii-h))
  96           (top (zqug-top-entry zqug))
  97           (cur (zqug-cur-entry zqug))
  98           )
  99
 100         (define (scrnprn qlst entry line)
 101                 (if (and (notnull? qlst)
 102                         (< line winh))
 103                          (if (< entry top)
 104                         (scrnprn (cdr qlst) (1+ entry) line)
 105                         (let* ((rect (rect-crop-down dims (* line sprite-lineheight)))
 106                                                         (icon (safe-eval (qst-icon (car qlst))))
 107                                                         (colorplus (cond ((qst-complete? (car qlst)) "^c+g")
 108                                                                                 ((qst-failed? (car qlst)) "^c+r")
 109                                                                                 (#t "^c+w")))
 110                                                         (rect (if (null? (quest-tbl-get (car qlst) 'qparent))
 111                                                                                 rect
 112                                                                                 (rect-crop-offset rect 12 0)))
 113                                                 )
 114                                         (if (> (rect-h rect) 0)
 115                                                 (begin
 116                                                         (if (not (null? icon))
 117                                                                 (kern-screen-draw-sprite rect 0 icon)
 118                                                         )
 119                                                         (kern-screen-print (rect-offset rect sprite-offset-x sprite-offset-y) 0 colorplus (qst-title (car qlst)) "^c-" )
 120                                                         (if (!= entry cur)
 121                                                                 (kern-screen-shade rect 128)
 122                                                         )
 123                                                         (scrnprn (cdr qlst) (1+ entry) (1+ line))
 124                                                 ))
 125                                 ))
 126                 ))
 127
 128      (if (null? pgob)
 129          (scrnprn "No Quests!")
 130          (let ((qlst (tbl-get pgob 'quests)))
 131            (if (not qlst)
 132                (scrnprn "No Quests Yet! (But keep trying!)")
 133                (scrnprn qlst 0 0)
 134                )))))
 135
 136  ;; select proc - run the ztats quest applet
 137  (lambda (zqug)
 138
 139    ;; ztats quest applet gob
 140    (define (zqag-mk) (list nil))
 141    (define (zqag-dims! zqag val) (set-car! zqag val))
 142    (define (zqag-dims zqag) (car zqag))
 143
 144    (let* ((pgob (gob (zqug-party zqug)))
 145           (qlst (tbl-get pgob 'quests))
 146                          (offset-page 0)
 147                                 )
 148      (if qlst
 149          (let ((qst (list-ref qlst (zqug-cur-entry zqug))))
 150
 151                                 (qst-status qst)
 152
 153            ;; paint proc - render the quest details pane
 154            (define (paint zqag)
 155              (let* ((rect (zqag-dims zqag))
 156                      (icon (safe-eval (qst-icon qst)))
 157                      (line-offset sprite-lineheight)
 158                  (display-lines-available (floor (/ (- (rect-h rect) sprite-lineheight kern-ascii-h) kern-ascii-h)))
 159                      (max-offset (length (qst-descr qst)))
 160                      )
 161                (kern-screen-erase rect)
 162                 (if (not (null? icon))
 163                         (kern-screen-draw-sprite rect 0 icon)
 164                 )
 165
 166                (kern-screen-print (rect-down rect sprite-offset-y) kern-sp-centered "^c+c" (qst-title qst) "^c-")
 167
 168                ;; set offset to sane values
 169                (if (> offset-page (- max-offset display-lines-available))
 170                      (set! offset-page (- max-offset display-lines-available))
 171                )
 172                (if (< offset-page 0)
 173                      (set! offset-page 0)
 174                )
 175
 176                                         (let ((offset-loop offset-page))
 177                                 (map (lambda (line)
 178                                         (if (and (eqv? offset-loop 0) (< (+ line-offset kern-ascii-h kern-ascii-h) (rect-h rect)))
 179                                                 (begin
 180                                         (set! line-offset (+ line-offset kern-ascii-h))
 181                                         (kern-screen-print (rect-down rect line-offset) 0 line )
 182                                                 )
 183                                                 (set! offset-loop (- offset-loop 1))
 184                                         ))
 185                                         (qst-descr qst)
 186                                 ))
 187
 188                (kern-screen-update rect)
 189                ))
 190
 191            (kern-applet-run
 192
 193             ;; run proc - paint & push a keyhandler that exits when player hits ESC
 194             (lambda (zqag dims)
 195               ;;(kern-status-set-title "Quest") //doesnt work right
 196               (zqag-dims! zqag dims)
 197               (paint zqag)
 198               (kern-event-run-keyhandler
 199                (lambda (key mod)
 200                  (cond ((or (= key kern-key-esc)
 201                                                                         (= key kern-key-space)
 202                                                                         (= key kern-key-return)
 203                                                                         (= key kern-key-enter))
 204                         #t)
 205                                                                 ((= key kern-key-up)
 206                                                                         (if (> offset-page 0)
 207                                                                                 (set! offset-page (- offset-page 1))
 208                                                                         )
 209                                                                         (paint zqag)
 210                                                                         #f
 211                                                                 )
 212                                                                 ((= key kern-key-down)
 213                                                                         (set! offset-page (+ offset-page 1))
 214                                                                         (paint zqag)
 215                                                                         #f
 216                                                                 )
 217                                                                 ((or (= key kern-key-pgup) (= key kern-key-kp-pgup))
 218                                                                         (set! offset-page (- offset-page (- (floor (/ (rect-h dims) kern-ascii-h)) 7)))
 219                                                                         (if (< offset-page 0)
 220                                                                                 (set! offset-page 0)
 221                                                                         )
 222                                                                         (paint zqag)
 223                                                                         #f
 224                                                                 )
 225                                                                 ((or (= key kern-key-pgdn) (= key kern-key-kp-pgdn))
 226                                                                         (set! offset-page (+ offset-page (- (floor (/ (rect-h dims) kern-ascii-h)) 7)))
 227                                                                         (paint zqag)
 228                                                                         #f
 229                                                                 )
 230                        (else
 231                         #f)))))
 232
 233             ;; paint
 234             paint
 235
 236             ;; zqa gob
 237             (zqag-mk)
 238             )))))
 239
 240  ;; zqu gob
 241  (zqug-mk))
 242
 243 )