Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- ; dungeon.scm - the game procedures
- ; dungeon-items.scm - the item table
- ; dungeon-rooms.scm - rooms (with references to encounters and other rooms)
- ; dungeon-enc.scm - an encounter (enemy/npc/loot)
- (define debug-calls #f)
- (define debug-damage #f)
- (define (start)
- (fmt " - Entering the Dungeon.")
- (if (file-exists? "dungeon.hnet")
- (begin
- ;load character
- (fmt "Load saved game? " 0)
- (let ((c (read)))
- (if (eq? c 'y)
- (let ((save (car (read-in "dungeon.hnet"))))
- ;(fmt "loaded " 0)
- ;(fmt save)
- (game-loop (car save) (cadr save) (caddr save) (cadr (cddr save)) 'new)
- )
- (delete-file "dungeon.hnet")
- )
- )
- )
- (begin
- ;create char
- ;...
- ;(fmt "New character:")
- ;(set! player '("" () ()))
- ;(fmt "Name: " 0)
- ;(set! player (insert player 1 (list 'name (read))))
- (fmt "You are a nameless servant of Dark, unchained from the curse of living.")
- (fmt "Now go forward into the deep caverns!")
- (fmt " ~~~ ")
- (fmt "")
- (game-loop starting-room starting-inventory starting-equipment starting-stats 'new)
- )
- )
- )
- (define (game-loop room inventory equipment stats . status)
- (if debug-calls (fmt (list "game-loop " room " " inventory " " equipment " " stats)))
- (if (not (null? status))
- (if (eq? (car status) 'new)
- (begin
- (fmt (cadr room))
- )
- )
- )
- (let ((enc-result (enc-loop (car room) inventory equipment stats)))
- (if (not (null? enc-result))
- (input-loop 0 room (elem enc-result 1) (elem enc-result 2) (elem enc-result 3))
- ; the input-loop will call the game-loop when adequate
- (begin
- (fmt "Game over.")
- (error "Your life force has run out.")
- )
- )
- )
- ;(game-loop room inventory equipment stats)
- )
- (define (enc-loop room-name inventory0 equipment0 stats0)
- (if debug-calls (fmt "enc-loop"))
- (if (is-visited room-name stats0)
- (list inventory0 equipment0 stats0)
- (let next-enc ((encs (room: 'encs room-name)) (inventory inventory0) (equipment equipment0) (stats stats0))
- (if (null? encs)
- (list inventory equipment (add-to-visited room-name stats)) ;when all completed
- (begin
- (case (caar encs)
- ((fight)
- (let ((result (fight-enemy (cadar encs) inventory equipment stats)))
- (if (< result 0)
- (begin
- (fmt " --- YOU DIED. ---")
- '()
- )
- (begin
- (fmt " --- You banished the enemy! The loot is yours!")
- (next-enc (cdr encs) (loot-enemy (cadar encs) inventory) equipment stats)
- )
- )
- )
- )
- ((item)
- (fmt "Item found: " 0)
- (fmt (cadar encs))
- (next-enc (cdr encs) (add-to-inventory (cadar encs) inventory) equipment stats)
- )
- )
- )
- )
- )
- )
- )
- (define (input-loop i room inventory equipment stats)
- (if debug-calls (fmt "input-loop"))
- (fmt "\ni: inventory | e: equipment | s: focus | g: move on")
- (let ((c (read)))
- (case c
- ((i)
- (let ((inv (list-inventory inventory equipment)))
- (fmt inv)
- (if (< (length inv) 1)
- (fmt "Your inventory is empty. :-(")
- (begin
- (fmt "> Equip (cancel with 'n'): " 0)
- (let ((item-no (read)))
- (if (number? item-no)
- (if (is-equipped (elem inventory item-no) equipment)
- (fmt "already equipped")
- (begin
- (input-loop 1 room inventory (equip-item (elem inventory item-no) equipment) stats)
- )
- )
- (input-loop 1 room inventory equipment stats)
- )
- )
- )
- )
- )
- )
- ((e)
- (let ((equip (list-equipment equipment)))
- (fmt equip)
- )
- )
- ((s)
- (let ((focus (stat: 'focus stats)))
- ;(fmt focus)
- (fmt "Focus on head area: " 0)
- (fmt (stat: 'head focus))
- (fmt "Focus on torso area: " 0)
- (fmt (stat: 'torso focus))
- (fmt "Focus on lateral area: " 0)
- (fmt (stat: 'arms focus))
- (fmt "Focus on leg area: " 0)
- (fmt (stat: 'legs focus))
- (fmt "You are not powerful enough to attune your focus.")
- )
- )
- ((g)
- (let g-loop ((rooms (list-doors room)))
- (fmt rooms)
- (fmt "> Go to room (cancel with 'n'): " 0)
- (let ((room-no (read)))
- (if (and (number? room-no) (< room-no (+ (length (room: 'doors (car room))) 1)))
- (let ((target-room (elem (room: 'doors (car room)) room-no)))
- (if (room-unlocked target-room)
- (begin
- (fmt "going to " 0)
- (fmt (cadr target-room))
- (let ((room-status (if (is-visited (cadr target-room) stats) 'revisit 'new)))
- (game-loop (room: 'all (cadr target-room)) inventory equipment stats room-status)
- )
- )
- (begin
- (fmt "This room requires the following key: " 0)
- (let ((key (caddr target-room)))
- (fmt key)
- (if (contains inventory key)
- (begin
- (fmt "\n - Unlocking with " 0)
- (fmt key)
- (fmt "\n")
- (game-loop (room: 'all (cadr target-room)) inventory equipment stats 'new)
- )
- (g-loop rooms)
- )
- )
- )
- )
- )
- (if (eq? room-no 'n)
- (input-loop 1 room inventory equipment stats)
- (begin
- (fmt " > Type one of the given numbers, or 'n' to cancel.")
- (g-loop rooms) ;retry for good input
- )
- )
- )
- )
- )
- )
- ((save)
- (fmt "Saving data..." 0)
- (write-out
- "dungeon.hnet"
- (list room inventory equipment stats)
- )
- (fmt "done.")
- )
- ;(else (input-loop 1 room inventory equipment stats))
- )
- )
- (input-loop 1 room inventory equipment stats)
- )
- ;;; Gegenstände
- (define items (load "dungeon-items.scm"))
- (define starting-inventory
- '(
- "Rusted Karak"
- ))
- (define starting-equipment
- '(
- (weapon "Bare Fists")
- (shield "Nothing")
- (head "Nothing")
- (torso "Nothing")
- (arms "Nothing")
- (hands "Nothing")
- (legs "Nothing")
- (feet "Nothing")
- (left-finger "Nothing")
- (right-finger "Nothing")
- (neck "Nothing")
- ))
- (define (item: x name)
- ; Retrieve information (x) about an item by its name
- (if debug-calls (fmt (list "item: " x " " name)))
- (let cont ((l items))
- (if (or (not name) (null? l))
- '!!!item-not-listed!!!
- (if (string=? (caar l) name)
- (if (eq? x 'all)
- (car l)
- (elem (car l) (case x ((description) 2) ((type) 3) ((stat damage armor) 4)))
- )
- (cont (cdr l))
- )
- )
- )
- )
- (define (add-to-inventory item-name inventory)
- (if debug-calls (fmt (list "add-to-inv " item-name " " inventory)))
- (append inventory (list item-name))
- )
- (define (list-inventory inv equipment . li)
- (if debug-calls (fmt (list "list-inv " inv " " li)))
- (if (null? inv)
- '()
- (cons
- (string-append
- "" (number->string (if (null? li) 1 (car li))) ": "
- (car inv)
- (if (is-equipped (car inv) equipment)
- (string-append
- " {equipped as "
- (symbol->string (item: 'type (car inv)))
- "} "
- )
- (string-append
- " => "
- (let ((comp (compare-to-equipped-item (car inv) equipment)))
- (if (> comp 0)
- (string-append "+" (number->string comp))
- (number->string comp)
- )
- )
- )
- )
- "\n"
- )
- (list-inventory (cdr inv) equipment (if (null? li) 2 (+ (car li) 1)))
- )
- )
- )
- (define (equip-item item-name equipment)
- (if debug-calls (fmt (list "equip " item-name)))
- (let cont ((l equipment))
- (if (null? l)
- '()
- (if (eq? (caar l) (item: 'type item-name))
- (begin
- (fmt "equipped " 0)
- (fmt item-name)
- (cons (list (caar l) item-name) (cont (cdr l)))
- )
- (cons (car l) (cont (cdr l)))
- )
- )
- )
- )
- (define (is-equipped name equipment)
- (if debug-calls (fmt (list "is-equipped " name)))
- (eqv?
- (item-in-slot (item: 'type name) equipment)
- name
- )
- )
- (define (compare-to-equipped-item item-name equipment)
- (if debug-calls (fmt (list "compare-item " item-name)))
- (-
- (item: 'stat item-name)
- (let ((equipped-item-name (item-in-slot (item: 'type item-name) equipment)))
- (if equipped-item-name
- (item: 'stat equipped-item-name)
- 0
- )
- )
- )
- )
- (define (item-in-slot slot equipment)
- (if debug-calls (fmt (list "item-in-slot " slot)))
- (let cont ((l equipment))
- (if (null? l)
- "Nothing"
- (if (eq? slot (caar l))
- (if (cadar l)
- (cadar l)
- "Nothing"
- )
- (cont (cdr l))
- )
- )
- )
- )
- (define (list-equipment equipment)
- (if debug-calls (fmt (list "list-equipment")))
- (let cont ((l equipment))
- (if (null? l)
- '()
- (cons
- (string-append
- (symbol->string (caar l)) " : "
- (if (cadar l)
- (string-append
- (cadar l) " "
- (number->string (item: 'stat (cadar l)))
- )
- "(empty)")
- "\n"
- )
- (cont (cdr l))
- )
- )
- )
- )
- ;;; Räume
- (define rooms (load "dungeon-rooms.scm"))
- (define starting-room (elem rooms 1))
- (define (list-doors room)
- (if debug-calls (fmt (list "list-doors " room)))
- (let cont ((l (room: 'doors (car room))) (li 1))
- (if (null? l)
- '()
- (cons
- (string-append
- "" (number->string li) ": "
- (cadar l)
- (case (caar l)
- ((open) " (open) ")
- ((jammed) " [Jammed!] ")
- ((locked) (string-append " [locked: " (cadr (cdar l)) "] "))
- )
- "\n"
- )
- (cont (cdr l) (+ li 1))
- )
- )
- )
- )
- (define (room: x name)
- (if debug-calls (fmt (list "room: " x " " name)))
- (let cont ((l rooms))
- ;(fmt (cadr (cdar l)))
- (if (null? l)
- '!!!given-room-not-defined!!!
- (if (string=? (caar l) name)
- (begin
- (case x
- ((all) (car l))
- ((description) (cadr l))
- ((enc encs encounters items actions) (cadr (cdar l)))
- ((doors) (cadr (cddar l)))
- )
- )
- (cont (cdr l))
- )
- )
- )
- )
- (define (room-unlocked door)
- (eq? (car door) 'open)
- )
- (define (add-to-visited room-name stats)
- (if debug-calls (fmt (list "add-to-visited " room-name " " stats)))
- (if (null? stats)
- '()
- (if (eq? (caar stats) 'visited)
- (cons (list (caar stats) (append (cadar stats) (list room-name))) (add-to-visited room-name (cdr stats)))
- (cons (car stats) (add-to-visited room-name (cdr stats)))
- )
- )
- )
- (define (is-visited room-name stats)
- (if debug-calls (fmt (list "is-visited " room-name " " stats)))
- (contains (stat: 'visited stats) room-name)
- )
- ;;; Spieler-Charakter
- (define player
- '()
- )
- (define starting-stats
- '(
- (life 800)
- (strength 4)
- (agility 5)
- (faith 1)
- (focus (
- (torso 0.4)
- (arms 0.3)
- (legs 0.2)
- (head 0.1)
- )
- )
- (visited ())
- ))
- (define (stat: x stat-list)
- (if debug-calls (fmt (list "stat: " x " " stat-list)))
- (if (null? stat-list)
- 0
- (if (eq? (caar stat-list) x)
- (cadar stat-list)
- (stat: x (cdr stat-list))
- )
- )
- )
- ;;; Gegner
- (define encounters (load "dungeon-enc.scm"))
- (define (fight-enemy enemy-name inventory equipment stats)
- (fmt "FIGHT: " 0)
- (fmt enemy-name)
- (let fight
- ((round 1) (my-hp 800) (enemy-hp (enemy: 'hp enemy-name))
- (enemy-equipment (enemy: 'equipment enemy-name))
- (enemy-stats (enemy: 'stats enemy-name))
- )
- (if (or (< my-hp 0) (< enemy-hp 0))
- my-hp
- (let* (
- (my-area (~attack-area stats))
- (my-attack (effective-damage my-area stats equipment enemy-equipment))
- (enemy-area (~attack-area enemy-stats))
- (enemy-attack (effective-damage enemy-area enemy-stats enemy-equipment equipment))
- )
- (fmt "You strike the enemy for " 0)
- (fmt my-attack 0)
- (fmt " damage! (" 0)
- (fmt my-area 0)
- (fmt ")")
- (fmt "You get hit for " 0)
- (fmt enemy-attack 0)
- (fmt " damage! (" 0)
- (fmt enemy-area 0)
- (fmt ")")
- (fmt "[ HP: " 0)
- (fmt my-hp 0)
- (fmt " ] ")
- (fight (+ round 1) (- my-hp enemy-attack) (- enemy-hp my-attack) enemy-equipment enemy-stats)
- )
- )
- )
- )
- (define (effective-damage attack-area src-stats src-equipment dest-equipment)
- (let* (;old: (attack-area (~attack-area src-stats))
- (result
- (-
- (*
- (stat: 'strength src-stats)
- (item: 'damage (item-in-slot 'weapon src-equipment))
- (area-effect attack-area)
- )
- (item: 'armor (item-in-slot attack-area dest-equipment))
- )
- ))
- (if debug-damage (fmt (list "[effective damage:" (stat: 'strength src-stats) "*" (item: 'damage (item-in-slot 'weapon src-equipment)) "*" (area-effect attack-area) "-" (item: 'armor (item-in-slot attack-area dest-equipment)) "]")))
- (if (< result 0) 0 result)
- )
- )
- (define (~attack-area stats)
- (let ((focus (stat: 'focus stats)))
- (if (list? focus)
- ; todo: choose random area according to focus
- (car (list-ref focus (random (length focus))))
- 'torso
- )
- )
- )
- (define (area-effect attacked-area)
- (case attacked-area
- ((head) 4.0)
- ((torso) 1.0)
- ((arms) 0.2)
- ((legs) 0.15)
- )
- )
- (define (loot-enemy enemy-name player-inventory)
- (if debug-calls (fmt (list "loot-enemy " enemy-name)))
- (let step ((items (enemy: 'items enemy-name)) (inv player-inventory))
- (if (null? items)
- inv
- (let ((ci (cadar items)))
- (fmt "You found: " 0)
- (fmt ci)
- (step (cdr items) (add-to-inventory ci inv))
- )
- )
- )
- )
- (define (enemy: x name)
- (if debug-calls (fmt (list "enemy: " x " " name)))
- (let cont ((l encounters))
- (if (null? l)
- #f
- (if (string=? (caar l) name)
- (case x
- ((type) (elem (car l) 2))
- ((stats) (elem (car l) 3))
- ((hp) (stat: 'hp (elem (car l) 3)))
- ((equipment items) (elem (car l) 4))
- )
- (cont (cdr l))
- )
- )
- )
- )
- (load "resource-bundle.scm")
- (start)
- (define enemy-titles
- (list
- "Slave" "Bruiser" "Headhunter" "Swordmaster" "Enchanter" "Travelling Knight"
- "Ascended Blademaster" "Mystic Aircaster" "Ancient Brute" "Sanctified Knight"
- "Nocturnal Master" "Dungeon Hero"
- )
- )
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement