garden.scm

   1 (import (chicken random)
   2         (chicken time)
   3         (chicken time posix)
   4         (chicken pathname)
   5         (chicken io)
   6         (chicken string)
   7         (chicken format)
   8         srfi-1)
   9
  10 (define rand-double pseudo-random-real)
  11
  12 (define (rand-weighted weights)
  13   (let* ((tot (apply + weights)))
  14     (let loop ((u (* (rand-double) tot))
  15                (rest weights)
  16                (idx 0))
  17       (if (null? rest)
  18           (error "Loop fell through")
  19           (let ((head (car rest)))
  20             (if (< u head)
  21                 idx
  22                 (loop (- u head)
  23                       (cdr rest)
  24                       (+ idx 1))))))))
  25
  26 (define (rand-choice l . weights)
  27   (list-ref l
  28             (if (null? weights)
  29                 (pseudo-random-integer (length l))
  30                 (rand-weighted weights))))
  31
  32 (define (make-garden user)
  33   `((user . ,user)
  34     (visits . 0)
  35     (created . ,(current-seconds))
  36     (age . 0)
  37     (last-updated . ,(current-seconds))
  38     (species . ,(rand-choice species))
  39     (colour . ,(rand-choice colours))
  40     (rarity . ,(rand-choice rarities 0.666666667 0.222222222 0.074074074 0.024691358 0.01234568))
  41     (last-watered . #f)
  42     (stage-idx . 0)))
  43
  44 (define (garden-prop p g)
  45   (cdr (assoc p g)))
  46
  47 (define (garden-prop-set! p v g)
  48   (alist-update! p v g))
  49
  50 (define (water-garden! g)
  51   (garden-prop-set! 'last-watered (current-seconds) g))
  52
  53 (define (garden-stage g)
  54   (let ((stage-idx (garden-prop 'stage-idx g)))
  55     (if (= stage-idx -1)
  56         'dead
  57         (list-ref stages stage-idx))))
  58
  59 (define (display-garden g)
  60   (let* ((idx (garden-prop 'stage-idx g))
  61          (basename (case idx
  62                      ((-1) "dead")
  63                      ((0) "seed")
  64                      ((1) "seedling")
  65                      (else
  66                       (conc (symbol->string (garden-prop 'species g)) (- (min idx 4) 1))))))
  67     (print (with-input-from-file (make-pathname "art" basename "txt") read-string))))
  68
  69 (define (describe-garden g)
  70   (let ((idx (garden-prop 'stage-idx g)))
  71     (cond
  72      ((= idx -1)
  73       (print (rand-choice (list-ref stage-descriptions (- (length stage-descriptions) 1)))))
  74      ((= idx 4)
  75       (print (format (rand-choice (list-ref stage-descriptions 4))
  76                      (garden-prop 'colour g)
  77                      (garden-prop 'species g))))
  78      (else
  79       (print (format (rand-choice (list-ref stage-descriptions idx))
  80                      (garden-prop 'species g))))')))
  81
  82 (define (display-water-level g)
  83   (let* ((last-watered (garden-prop 'last-watered g)))
  84     (if last-watered
  85         (let* ((now (current-seconds))
  86                (1day (* 24 3600))
  87                (remaining-pc (quotient (* 100 (- 1day (- now last-watered))) 1day))
  88                (filled (quotient remaining-pc 4))
  89                (unfilled (- 25 filled)))
  90           (print "["
  91                  (make-string filled #\~)
  92                  (make-string unfilled #\.)
  93                  "] " remaining-pc "%"))
  94         (print "[" (make-string 25 #\.) "]\n"
  95                "Your plant hasn't been watered!"))))
  96
  97 ;; Growth
  98
  99 (define (update-garden! g)
 100   (let* ((now (current-seconds))
 101          (created (garden-prop 'created g))
 102          (last-watered (garden-prop 'last-watered g)))
 103     (if (not last-watered)
 104         (if (> (- now created) (* 3600 24))
 105             (garden-prop-set! 'stage-idx -1 g))
 106         (let* ((time-since-last-watered (- now last-watered))
 107                (last-updated (garden-prop 'last-updated g))
 108                (1day (* 24 3600))
 109                (5days (* 5 1day))
 110                (growing-time (max (- (min now (+ last-watered 1day))
 111                                      last-updated)
 112                                   0)))
 113           (if (> time-since-last-watered 5days)
 114               (garden-prop-set! 'stage-idx -1 g)
 115               (let* ((new-age (+ (garden-prop 'age g) growing-time))
 116                      (new-stage-idx-raw (list-index (lambda (max-age) (> max-age new-age))
 117                                                     stage-transition-times))
 118                      (new-stage-idx (if new-stage-idx-raw
 119                                         new-stage-idx-raw
 120                                         (length stage-transition-times))))
 121                 (garden-prop-set! 'age new-age g)
 122                 (garden-prop-set! 'stage-idx new-stage-idx g)))))
 123     (garden-prop-set! 'last-updated now g)))
 124
 125
 126 ;;; Data
 127
 128 (define stage-transition-times
 129   ;; '(10 20 30 40 50)) ; for debugging
 130   (list (* 3600 24)
 131         (* 3600 24 3)
 132         (* 3600 24 10)
 133         (* 3600 24 20)
 134         (* 3600 24 30)))
 135
 136 (define stages
 137   '(seed seedling young mature flowering seed-bearing))
 138
 139 (define colours
 140   '(red orange yellow green blue indigo violet white black gold rainbow))
 141
 142 (define rarities
 143   '(common uncommon rare legendary godly))
 144
 145 (define species
 146   '(poppy
 147     cactus
 148     aloe
 149     venus\ flytrap
 150     jade\ plant
 151     fern
 152     daffodil
 153     sunflower
 154     baobab
 155     lithops
 156     hemp
 157     pansy
 158     iris
 159     agave
 160     ficus
 161     moss
 162     sage
 163     snapdragon
 164     columbine
 165     brugmansia
 166     palm
 167     pachypodium))
 168
 169
 170 (define mutation
 171   '(humming
 172     noxious
 173     vorpal
 174     glowing
 175     electric
 176     icy
 177     flaming
 178     psychic
 179     screaming
 180     chaotic
 181     hissing
 182     gelatinous
 183     deformed
 184     shaggy
 185     scaly
 186     depressed
 187     anxious
 188     metallic
 189     glossy
 190     psychedelic
 191     bonsai
 192     foamy
 193     singing
 194     fractal
 195     crunchy
 196     goth
 197     oozing
 198     stinky
 199     aromatic
 200     juicy
 201     smug
 202     vibrating
 203     lithe
 204     chalky
 205     naive
 206     ersatz
 207     disco
 208     levitating
 209     colossal
 210     luminous
 211     cosmic
 212     ethereal
 213     cursed
 214     buff
 215     narcotic
 216     gnu/linux
 217     abraxan))
 218
 219 (define stage-descriptions
 220   '(("You're excited about your new seed."
 221      "You wonder what kind of plant your seed will grow into."
 222      "You're ready for a new start with this plant."
 223      "You're tired of waiting for your seed to grow."
 224      "You wish your seed could tell you what it needs."
 225      "You can feel the spirit inside your seed."
 226      "These pretzels are making you thirsty."
 227      "Way to plant, Ann!"
 228      "'To see things in the seed, that is genius' - Lao Tzu")
 229
 230     ("The seedling fills you with hope."
 231      "The seedling shakes in the wind."
 232      "You can make out a tiny leaf - or is that a thorn?"
 233      "You can feel the seedling looking back at you."
 234      "You blow a kiss to your seedling."
 235      "You think about all the seedlings who came before it."
 236      "You and your seedling make a great team."
 237      "Your seedling grows slowly and quietly."
 238      "You meditate on the paths your plant's life could take.")
 239
 240     ("The ~A makes you feel relaxed."
 241      "You sing a song to your ~A."
 242      "You quietly sit with your ~A for a few minutes."
 243      "Your ~A looks pretty good."
 244      "You play loud techno to your ~A."
 245      "You play piano to your ~A."
 246      "You play rap music to your ~A."
 247      "You whistle a tune to your ~A."
 248      "You read a poem to your ~A."
 249      "You tell a secret to your ~A."
 250      "You play your favorite record for your ~A.")
 251
 252     ("Your ~A is growing nicely!"
 253      "You're proud of the dedication it took to grow your ~A."
 254      "You take a deep breath with your ~A."
 255      "You think of all the words that rhyme with ~A."
 256      "The ~A looks full of life."
 257      "The ~A inspires you."
 258      "Your ~A makes you forget about your problems."
 259      "Your ~A gives you a reason to keep going."
 260      "Looking at your ~A helps you focus on what matters."
 261      "You think about how nice this ~A looks here."
 262      "The buds of your ~A might bloom soon.")
 263
 264     ("The ~A flowers look nice on your ~A!"
 265      "The ~A flowers have bloomed and fill you with positivity."
 266      "The ~A flowers remind you of your childhood."
 267      "The ~A flowers remind you of spring mornings."
 268      "The ~A flowers remind you of a forgotten memory."
 269      "The ~A flowers remind you of your happy place."
 270      "The aroma of the ~A flowers energize you."
 271      "The ~A has grown beautiful ~A flowers."
 272      "The ~A petals remind you of that favorite shirt you lost."
 273      "The ~A flowers remind you of your crush."
 274      "You smell the ~A flowers and are filled with peace.")
 275
 276     ("You fondly remember the time you spent caring for your ~A."
 277      "Seed pods have grown on your ~A."
 278      "You feel like your ~A appreciates your care."
 279      "The ~A fills you with love."
 280      "You're ready for whatever comes after your ~A."
 281      "You're excited to start growing your next plant."
 282      "You reflect on when your ~A was just a seedling."
 283      "You grow nostalgic about the early days with your ~A.")
 284
 285     ("You wish you had taken better care of your plant."
 286      "If only you had watered your plant more often.."
 287      "Your plant is dead, there's always next time."
 288      "You cry over the withered leaves of your plant."
 289      "Your plant died. Maybe you need a fresh start.")))