worlds/haxima-1.002/quest-sys.scm

   1 ;; Defines the basic stuff for the haxima quest system
   2
   3 ;; Create a new quest.
   4 ;;
   5 ;; title - a string that will be shown in the quest log listing and at the top
   6 ;; of the quest pane
   7 ;;
   8 ;; tag - an optional tag (preferably unique) that can be used to retrieve the quest.
   9 ;;
  10 ;; descr - a list of strings (ie paragraph) that will be shown in the quest pane
  11 ;;
  12 ;; assign - an optional symbol[1] for a proc that will run when the quest is assigned;
  13 ;; of the form (assign quest target), where 'quest' is the thing being created right
  14 ;; here and 'target' is the (scheme) object the quest is being assigned to. Iff
  15 ;; 'assign' returns #t then the quest will be added to the target's list of
  16 ;; quests.
  17 ;;
  18 ;; status - an optional symbol [1] for a proc that will be called by the ztats pane, of
  19 ;; the form (status quest), when the quest details are shown in the quest log.
  20 ;; It is called before the description is written, so it may alter that if required.
  21 ;; The method should return a list of strings to be appended to the description, or nil
  22 ;; Note that this should not be used to update the icon or inprog/done/failed status, as
  23 ;; they are used in the preceeding panel.
  24 ;;
  25 ;; icon - symbol [1] for sprite to use for the quest UI
  26 ;;
  27 ;; payload - whatever you want for your particular quest (this is an optional
  28 ;; number of parms)
  29 ;;
  30 ;; (* optional = use nil to ignore)
  31 ;;
  32 ;; Example:
  33 ;;
  34 ;;   (qst-mk "Find 6 Foozles"
  35 ;;           '(
  36 ;;              "If you find 6 Foozles, Mr. Squeejie will give you an enchanted toothpick."
  37 ;;                              ""
  38 ;;              "Seek them out in distant Foozleburg"
  39 ;;            )
  40 ;;           'find-foozle-assign
  41 ;;           'find-foozle-status
  42 ;;                       's_quest_foozles
  43 ;;           0 ; payload tracks num foozles found so far
  44 ;;           )
  45 ;;
  46 ;; Notes:
  47 ;;
  48 ;; [1] The symbol of a proc named foo is 'foo. You must use a symbol because
  49 ;; the name of the procedure must be saved as part of an object's gob. It would
  50 ;; be nice if you could just pass in a lambda, but saving and reloading lambda
  51 ;; closures is left as an exercise for the advanced reader. BTW, this rule
  52 ;; applies within the payload lists as well.
  53 ;;
  54 (define (qst-mk title tag descr assign status icon . payload)
  55   (if (or (not (symbol? assign))
  56           (not (symbol? status)))
  57       (error "qst-mk: 'assign' and 'status' must be the symbols for procedures (ie, not the procedures themselves)"))
  58   (list 'quest title tag descr assign status 'inprogress icon payload))
  59
  60 (define (qst-title qst) (list-ref qst 1))
  61
  62 (define (qst-tag qst) (list-ref qst 2))
  63
  64 (define (qst-descr qst) (list-ref qst 3))
  65
  66 (define (qst-assign qst target)
  67   (println "qst-assign")
  68   (apply (eval (list-ref qst 4))
  69          (list qst target)))
  70
  71 (define (qst-status qst)
  72         (let ((statfn (list-ref qst 5)))
  73                 (if (not (null? statfn))
  74                         (apply (eval statfn) (list qst))
  75                 ))
  76 )
  77
  78 (define (qst-done? qst)
  79   ;;(println "qst-done? qst=" qst)
  80   (list-ref qst 6))
  81
  82 (define (qst-done! qst result)
  83         ;;(kern-log-msg "^c+gYou have completed the quest ^c+w" (qst-title qst) "^c-!^c-")
  84         (if (not (equal? (list-ref qst 6) result))
  85                 (begin
  86                         (list-set-ref! qst 6 result)
  87                         (qst-bump! qst)
  88                 )
  89         ))
  90
  91 (define (qst-complete? qst)
  92         (equal? (list-ref qst 6) 'complete))
  93
  94 (define (qst-complete! qst)
  95   (qst-done! qst 'complete))
  96
  97 (define (qst-failed? qst)
  98         (equal? (list-ref qst 6) 'failed))
  99
 100 (define (qst-failed! qst)
 101   (qst-done! qst 'failed))
 102
 103 (define (qst-icon qst) (list-ref qst 7))
 104
 105 (define (qst-payload qst) (list-ref qst 8))
 106
 107 (define (quest-assign qst)
 108   (println "quest-assign")
 109   (let ((target (gob (kern-get-player))))
 110     (if (and (notnull? qst)
 111              (notnull? target)
 112              (qst-assign qst target))
 113         (begin
 114                 (quest-insert qst)
 115           ;;(tbl-append! target 'quests qst)
 116           ;;(println "quest-assign: " target)
 117           ;;(kern-log-msg "^c+gYou have a new quest: " (qst-title qst) "^c-")
 118           ))))
 119
 120 (define (quest-assigned? qst)
 121         (println "quest-assigned?")
 122         (let* ((target (gob (kern-get-player)))
 123                         (qstlist (tbl-get target 'quests))
 124                         )
 125                 (if (or (null? qst)
 126                                 (null? qstlist)
 127                                 )
 128                         #f
 129                         (in-list? qst qstlist)
 130         )
 131         ))
 132
 133 ;; first item, if any, else nil
 134 (define (safe-car alist)
 135         (cond ((null? alist)
 136                 nil)
 137                 ((pair? alist)
 138                 (car alist))
 139                 (#t alist)))
 140
 141 (define (quest-get tag)
 142         (safe-car
 143                 (filter
 144                         (lambda (quest) (eq? (qst-tag quest) tag))
 145                         (tbl-get (gob (kern-get-player)) 'quests)
 146                 )
 147         ))
 148
 149 (define (quest-remove qst)
 150         ;; (cons a nil) = a; (cons nil b) != b;
 151         (define (quest-remove-helper qstlist)
 152                 (if (null? qstlist) nil
 153                         (let ((qhead (safe-car qstlist)))
 154                                 (println "rem? " (eq? qhead qst) " " )
 155                                 (if (eq? qhead qst)
 156                                         (cdr qstlist)
 157                                         (cons
 158                                                 qhead
 159                                                 (quest-remove-helper (cdr qstlist))
 160                                         )
 161                                 )
 162                         )
 163                 ))
 164         (let* ((target (gob (kern-get-player)))
 165                         (trimmed  (quest-remove-helper (tbl-get target 'quests) qst))
 166                         )
 167                 (if (null? trimmed)
 168                         (tbl-rm! target 'quests)
 169                         (tbl-set! target 'quests trimmed)
 170                         )
 171         ))
 172
 173 (define (qst-set-title! qst title) (list-set-ref! qst 1 title))
 174 (define (qst-set-descr! qst descr) (list-set-ref! qst 3 descr))
 175 (define (qst-set-icon! qst icon) (list-set-ref! qst 7 icon))
 176
 177 ;; bump the quest to the top of its appropriate list
 178 (define (qst-bump! quest)
 179         (define (qst-bump-base! qst)
 180                 (if (quest-assigned? qst)
 181                         (begin
 182                                 (quest-remove qst)
 183                                 (quest-insert qst)
 184                         )
 185                 ))
 186         ;; if we have a parent quest, bump that first
 187         (let ((parent (quest-tbl-get quest 'qparent)))
 188                 (if (not (null? parent))
 189                         (let ((pqst (quest-get parent)))
 190                                 (if (not (null? pqst))
 191                                         (qst-bump! pqst)
 192                                 ))
 193                 ))
 194         (qst-bump-base! quest)
 195         ;; if we have children, bump them
 196         (let ((childlist (quest-tbl-get quest 'qchildren)))
 197                 (println childlist)
 198                 (map (lambda (entry)
 199                                 (let ((cqst (quest-get entry)))
 200                                         (if (not (null? cqst))
 201                                                 (qst-bump-base! cqst)
 202                                                 )
 203                                         ))
 204                          childlist)
 205                 )
 206         )
 207
 208 (define (quest-insert qst)
 209         (let* ((target (gob (kern-get-player)))
 210                         (targlist (tbl-get target 'quests))
 211                         (inserttype (qst-done? qst))
 212                         (parent (quest-tbl-get qst 'qparent))
 213                         )
 214                 (define (insert-here? testee)
 215                         (cond ((eq? inserttype 'inprogress) #t)
 216                                 ((eq? inserttype (qst-done? testee)) #t)
 217                                 ((eq? 'failed (qst-done? testee)) #t)
 218                                 (#t #f))
 219                         )
 220                 (define (quest-insert-helper qstlist)
 221                         (if (null? qstlist) (list qst)
 222                                 (let ((qhead (safe-car qstlist)))
 223                                         (if (insert-here? qhead)
 224                                                 (cons qst qstlist)
 225                                                 (cons
 226                                                         qhead
 227                                                         (quest-insert-helper (cdr qstlist))
 228                                                 )
 229                                         )
 230                                 )
 231                         ))
 232                 (define (quest-insertchild-helper qstlist)
 233                         (if (null? qstlist) (list qst)
 234                                 (let ((qhead (safe-car qstlist)))
 235                                         (if (or (not (equal? parent (quest-tbl-get qhead 'qparent)))
 236                                                         (insert-here? qhead))
 237                                                 (cons qst qstlist)
 238                                                 (cons
 239                                                         qhead
 240                                                         (quest-insertchild-helper (cdr qstlist))
 241                                                 )
 242                                         )
 243                                 )
 244                         ))
 245                 (define (quest-insert-findparent qstlist)
 246                         (if (null? qstlist) (nil)
 247                                 (let ((qhead (safe-car qstlist)))
 248                                         (if (equal? parent (qst-tag qhead))
 249                                                 (cons
 250                                                         qhead
 251                                                         (quest-insertchild-helper (cdr qstlist))
 252                                                 )
 253                                                 (cons
 254                                                         qhead
 255                                                         (quest-insert-findparent (cdr qstlist))
 256                                                 )
 257                                         )
 258                                 )
 259                         ))
 260                 (cond ((null? targlist) (tbl-append! target 'quests qst))
 261                         ((null? parent) (tbl-set! target 'quests (quest-insert-helper targlist)))
 262                         (#t (tbl-set! target 'quests (quest-insert-findparent targlist)))
 263                         )
 264         ))
 265
 266 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 267 ;; Some special handling for quests with tbl payloads
 268
 269 (define (quest-tbl? quest)
 270         (let ((qpayload (qst-payload quest)))
 271                 (cond ((not (pair? qpayload)) #f)
 272                          ((not (pair? (car qpayload))) #f)
 273                         (#t (is-tbl? (car qpayload)))
 274                 )
 275         ))
 276
 277 (define (quest-tbl-get quest tag)
 278         (let ((qpayload (qst-payload quest)))
 279                 (cond ((not (pair? qpayload)) nil)
 280                          ((not (pair? (car qpayload))) nil)
 281                         ((not (is-tbl? (car qpayload))) nil)
 282                         (#t (tbl-get (car qpayload) tag))
 283                 )
 284         ))