プログラミングGauche アドベンチャーゲーム

アドベンチャーゲーム

;; -*- coding: utf-8 -*-

(use util.match)

(define *player*
  (make-player 'hp 320 'mp 66 'position (car *dungeon*)
               'inventory '(potion potion daggar cookie daggar)))

(define (reset!)
  (set! *player*
        (make-player 'hp 320 'mp 66 'position (car *dungeon*)
                     'inventory '(potion potion dagger cookie daggar))))

(define (make-player . args)
  (let loop ((lis args))
    (match lis
           [() '()]
           [(attr value . rest) (cons (cons attr value) (loop rest))]
           [_ (error "Number of arguments must be even:" args)])))

(define *dungeon*
  '(["あなたは森の北端にいる。道は南に続いている。"
     (s . 1)]
    ["あなたは鬱蒼とした森の中の道にいる。森は南北に伸びている。東に降りてゆく小径がある。"
     (n . 0)
     (s . 2)
     (e . 3)]
    ["足元がぬかるんでいる。道は直角に折れ、北と西に伸びている。西に続く道の先が明るくなっている。"
     (n . 1)
     (w . 4)]
    ["あなたは沼のほとりにいる。空気の動きが止まり、暑さを感じる。西に昇ってゆく小径がある。"
     (w . 1)]
    ["突然目の前が開けた。あなたは森の中の広場にいる。丈の短い、柔らかそうな草が一面に広場を覆っている。道が東に伸びている。"
     (e . 2)]))

(define *item-database*
  `((potion (drink . ,(cut add-hp! <> 50))
            (throw . ,(cut add-hp! <> -3)))
    (elixir (drink . ,(cut add-mp! <> 50))
            (throw . ,(cut add-mp! <> -3)))
    (pancake (eat . ,(cut add-hp! <> 30))
             (throw . ,(cut add-hp! <> -2)))
    (cookie (eat . ,(cut add-hp! <> 7))
            (throw . ,(cut add-hp! <> -1)))
    (dagger (throw . ,(lambda (_) #f)))))

(define (get-player-attr player attr)
  (cdr (assoc attr player)))

(define (update-player-attr! player attr updater)
  (let ((p (assoc attr player)))
    (set! (cdr p) (updater (cdr p)))))

(define (get-inventory player)
  (get-player-attr player 'inventory))

(define (has-item? player item)
  (member item (get-inventory player)))

(define (delete-item! player item)
  (update-player-attr! player 'inventory (cut delete-1 item <>)))

(define (delete-1 elt lis . options)
  (let-optionals* options ((cmp-fn equal?))
                  (let loop ((lis lis))
                    (cond [(null? lis) '()]
                          [(cmp-fn elt (car lis)) (cdr lis)]
                          [else (cons (car lis) (loop (cdr lis)))]))))

(define (add-item! player item)
  (update-player-attr! player 'inventory (cut cons item <>)))

(define (get-hp player)
  (get-player-attr player 'hp))

(define (add-hp! player n)
  (update-player-attr! player 'hp (cut + n <>)))

(define (get-mp player)
  (get-player-attr player 'mp))

(define (add-mp! player n)
  (update-player-attr! player 'mp (cut + n <>)))

(define (get-position player)
  (get-player-attr player 'position))

(define (set-position! player pos)
  (update-player-attr! player 'position (lambda (_) pos)))

(define (use-item! what item)
  (cond [(not (has-item? *player* item))
         (print item "を持っていません。")]
        [(itemproperty-get item what)
         => (lambda (action)
              (delete-item! *player* item)
              (action *player*))]
        [else (print item "を" what "することはできません。")])
  #t)

(define (item-properties item)
  (cond [(assoc item *item-database*) => cdr]
        [else '()]))

(define (itemproperty-get item what)
  (cond [(assoc what (item-properties item)) => cdr]
        [else #f]))

(define (describe)
  (print (car (get-position *player*)))
  #t)

(define (move! direction)
  (let ((position (get-position *player*)))
    (cond [(assoc direction (cdr position))
           => (lambda (p)
                (set-position! *player* (list-ref *dungeon* (cdr p))))]
          [else (print "そちらには移動できません。")]))
  #t)

(define (status)
  (print "hp :" (get-hp *player*))
  (print "mp :" (get-mp *player*))
  (print "inventory :" (get-inventory *player*))
  #t)