--- /dev/null
+(import (chicken random)
+ (chicken time)
+ (chicken time posix)
+ (chicken pathname)
+ (chicken io)
+ (chicken string)
+ (chicken format)
+ srfi-1)
+
+(define rand-double pseudo-random-real)
+
+(define (rand-weighted weights)
+ (let* ((tot (apply + weights)))
+ (let loop ((u (* (rand-double) tot))
+ (rest weights)
+ (idx 0))
+ (if (null? rest)
+ (error "Loop fell through")
+ (let ((head (car rest)))
+ (if (< u head)
+ idx
+ (loop (- u head)
+ (cdr rest)
+ (+ idx 1))))))))
+
+(define (rand-choice l . weights)
+ (list-ref l
+ (if (null? weights)
+ (pseudo-random-integer (length l))
+ (rand-weighted weights))))
+
+(define (make-garden user)
+ `((user . ,user)
+ (visits . 0)
+ (created . ,(current-seconds))
+ (age . 0)
+ (last-updated . ,(current-seconds))
+ (species . ,(rand-choice species))
+ (colour . ,(rand-choice colours))
+ (rarity . ,(rand-choice rarities 0.666666667 0.222222222 0.074074074 0.024691358 0.01234568))
+ (last-watered . #f)
+ (stage-idx . 0)))
+
+(define (garden-prop p g)
+ (cdr (assoc p g)))
+
+(define (garden-prop-set! p v g)
+ (alist-update! p v g))
+
+(define (water-garden! g)
+ (garden-prop-set! 'last-watered (current-seconds) g))
+
+(define (garden-stage g)
+ (let ((stage-idx (garden-prop 'stage-idx g)))
+ (if (= stage-idx -1)
+ 'dead
+ (list-ref stages stage-idx))))
+
+(define (display-garden g)
+ (let* ((idx (garden-prop 'stage-idx g))
+ (basename (case idx
+ ((-1) "dead")
+ ((0) "seed")
+ ((1) "seedling")
+ (else
+ (conc (symbol->string (garden-prop 'species g)) (- (min idx 4) 1))))))
+ (print (with-input-from-file (make-pathname "art" basename "txt") read-string))))
+
+(define (describe-garden g)
+ (let ((idx (garden-prop 'stage-idx g)))
+ (cond
+ ((= idx -1)
+ (print (rand-choice (list-ref stage-descriptions (- (length stage-descriptions) 1)))))
+ ((= idx 4)
+ (print (format (rand-choice (list-ref stage-descriptions 4))
+ (garden-prop 'colour g)
+ (garden-prop 'species g))))
+ (else
+ (print (format (rand-choice (list-ref stage-descriptions idx))
+ (garden-prop 'species g))))')))
+
+(define (display-water-level g)
+ (let* ((last-watered (garden-prop 'last-watered g)))
+ (if last-watered
+ (let* ((now (current-seconds))
+ (1day (* 24 3600))
+ (remaining-pc (quotient (* 100 (- 1day (- now last-watered))) 1day))
+ (filled (quotient remaining-pc 4))
+ (unfilled (- 25 filled)))
+ (print "["
+ (make-string filled #\~)
+ (make-string unfilled #\.)
+ "] " remaining-pc "%"))
+ (print "[" (make-string 25 #\.) "]\n"
+ "Your plant hasn't been watered!"))))
+
+;; Growth
+
+(define (update-garden! g)
+ (let* ((now (current-seconds))
+ (created (garden-prop 'created g))
+ (last-watered (garden-prop 'last-watered g)))
+ (if (not last-watered)
+ (if (> (- now created) (* 3600 24))
+ (garden-prop-set! 'stage-idx -1 g))
+ (let* ((time-since-last-watered (- now last-watered))
+ (last-updated (garden-prop 'last-updated g))
+ (1day (* 24 3600))
+ (5days (* 5 1day))
+ (growing-time (max (- (min now (+ last-watered 1day))
+ last-updated)
+ 0)))
+ (if (> time-since-last-watered 5days)
+ (garden-prop-set! 'stage-idx -1 g)
+ (let* ((new-age (+ (garden-prop 'age g) growing-time))
+ (new-stage-idx-raw (list-index (lambda (max-age) (> max-age new-age))
+ stage-transition-times))
+ (new-stage-idx (if new-stage-idx-raw
+ new-stage-idx-raw
+ (length stage-transition-times))))
+ (garden-prop-set! 'age new-age g)
+ (garden-prop-set! 'stage-idx new-stage-idx g)))))
+ (garden-prop-set! 'last-updated now g)))
+
+
+;;; Data
+
+(define stage-transition-times
+ '(10 20 30 40 50))
+ ;; (list (* 3600 24)
+ ;; (* 3600 24 3)
+ ;; (* 3600 24 10)
+ ;; (* 3600 24 20)
+ ;; (* 3600 24 30)))
+
+(define stages
+ '(seed seedling young mature flowering seed-bearing))
+
+(define colours
+ '(red orange yellow green blue indigo violet white black gold rainbow))
+
+(define rarities
+ '(common uncommon rare legendary godly))
+
+(define species
+ '(poppy
+ cactus
+ aloe
+ venus\ flytrap
+ jade\ plant
+ fern
+ daffodil
+ sunflower
+ baobab
+ lithops
+ hemp
+ pansy
+ iris
+ agave
+ ficus
+ moss
+ sage
+ snapdragon
+ columbine
+ brugmansia
+ palm
+ pachypodium))
+
+
+(define mutation
+ '(humming
+ noxious
+ vorpal
+ glowing
+ electric
+ icy
+ flaming
+ psychic
+ screaming
+ chaotic
+ hissing
+ gelatinous
+ deformed
+ shaggy
+ scaly
+ depressed
+ anxious
+ metallic
+ glossy
+ psychedelic
+ bonsai
+ foamy
+ singing
+ fractal
+ crunchy
+ goth
+ oozing
+ stinky
+ aromatic
+ juicy
+ smug
+ vibrating
+ lithe
+ chalky
+ naive
+ ersatz
+ disco
+ levitating
+ colossal
+ luminous
+ cosmic
+ ethereal
+ cursed
+ buff
+ narcotic
+ gnu/linux
+ abraxan))
+
+(define stage-descriptions
+ '(("You're excited about your new seed."
+ "You wonder what kind of plant your seed will grow into."
+ "You're ready for a new start with this plant."
+ "You're tired of waiting for your seed to grow."
+ "You wish your seed could tell you what it needs."
+ "You can feel the spirit inside your seed."
+ "These pretzels are making you thirsty."
+ "Way to plant, Ann!"
+ "'To see things in the seed, that is genius' - Lao Tzu")
+
+ ("The seedling fills you with hope."
+ "The seedling shakes in the wind."
+ "You can make out a tiny leaf - or is that a thorn?"
+ "You can feel the seedling looking back at you."
+ "You blow a kiss to your seedling."
+ "You think about all the seedlings who came before it."
+ "You and your seedling make a great team."
+ "Your seedling grows slowly and quietly."
+ "You meditate on the paths your plant's life could take.")
+
+ ("The ~A makes you feel relaxed."
+ "You sing a song to your ~A."
+ "You quietly sit with your ~A for a few minutes."
+ "Your ~A looks pretty good."
+ "You play loud techno to your ~A."
+ "You play piano to your ~A."
+ "You play rap music to your ~A."
+ "You whistle a tune to your ~A."
+ "You read a poem to your ~A."
+ "You tell a secret to your ~A."
+ "You play your favorite record for your ~A.")
+
+ ("Your ~A is growing nicely!"
+ "You're proud of the dedication it took to grow your ~A."
+ "You take a deep breath with your ~A."
+ "You think of all the words that rhyme with ~A."
+ "The ~A looks full of life."
+ "The ~A inspires you."
+ "Your ~A makes you forget about your problems."
+ "Your ~A gives you a reason to keep going."
+ "Looking at your ~A helps you focus on what matters."
+ "You think about how nice this ~A looks here."
+ "The buds of your ~A might bloom soon.")
+
+ ("The ~A flowers look nice on your ~A!"
+ "The ~A flowers have bloomed and fill you with positivity."
+ "The ~A flowers remind you of your childhood."
+ "The ~A flowers remind you of spring mornings."
+ "The ~A flowers remind you of a forgotten memory."
+ "The ~A flowers remind you of your happy place."
+ "The aroma of the ~A flowers energize you."
+ "The ~A has grown beautiful ~A flowers."
+ "The ~A petals remind you of that favorite shirt you lost."
+ "The ~A flowers remind you of your crush."
+ "You smell the ~A flowers and are filled with peace.")
+
+ ("You fondly remember the time you spent caring for your ~A."
+ "Seed pods have grown on your ~A."
+ "You feel like your ~A appreciates your care."
+ "The ~A fills you with love."
+ "You're ready for whatever comes after your ~A."
+ "You're excited to start growing your next plant."
+ "You reflect on when your ~A was just a seedling."
+ "You grow nostalgic about the early days with your ~A.")
+
+ ("You wish you had taken better care of your plant."
+ "If only you had watered your plant more often.."
+ "Your plant is dead, there's always next time."
+ "You cry over the withered leaves of your plant."
+ "Your plant died. Maybe you need a fresh start.")))
--- /dev/null
+;; View a garden
+;;
+
+(lambda (uri)
+ (import
+ (chicken condition)
+ (chicken file)
+ uri-common)
+ (for-each eval (with-input-from-file "garden.scm" read-list))
+ (serve-document-header (ext->mime "gmi"))
+ (let ((query (uri-query uri)))
+ (if (null? query)
+ (begin
+ (print "=> register.scm Please register first."))
+ (let ((hash (symbol->string (caar query))))
+ (condition-case
+ (let* ((g (with-input-from-file (make-pathname "accounts" hash) read))
+ (user (garden-prop 'user g))
+ (visits (+ 1 (garden-prop 'visits g))))
+ (garden-prop-set! 'visits visits g)
+
+ (print "# " user "'s garden\n")
+ (if (> visits 1)
+ (begin
+ (print "Welcome back, " user "!\n")
+ (print "You have visited your garden " visits " times.\n"))
+ (begin
+ (print "Welcome to your new garden, " user "!\n"
+ "\nTo visit and chieck on your garden, you'll need to use this link:\n"
+ (uri->string uri) "\n"
+ "Remember to bookmark it to keep it safe!\n")))
+
+ (update-garden! g)
+ (with-output-to-file (make-pathname "accounts" hash)
+ (lambda ()
+ (write g)))
+
+ (print "```")
+ (display-garden g)
+ (print "```")
+ (describe-garden g)
+
+ (print "\nWater level:")
+ (print "```")
+ (display-water-level g)
+ (print "```")
+ (print "\n=> water.scm?" hash " Water plant\n")
+
+ (when (= (garden-prop 'stage-idx g) 5)
+ (print "=> plant-new.scm?" hash " Plant a new seed\n"))
+
+ (print "=> delete-confirm.scm?" hash " Delete garden (irreversible!)"))
+ (o (exn)
+ (print "This garden no longer exists.\n\n"
+ "=> register.scm Register to create another.")))))))
+
The Lambda Lab / projects / microbotany.git / commitdiff