Guest User

dungeon

a guest
Feb 8th, 2019
108
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. ; dungeon.scm - the game procedures
  2. ; dungeon-items.scm - the item table
  3. ; dungeon-rooms.scm - rooms (with references to encounters and other rooms)
  4. ; dungeon-enc.scm - an encounter (enemy/npc/loot)
  5.  
  6. (define debug-calls #f)
  7. (define debug-damage #f)
  8. (define (start)
  9.     (fmt " - Entering the Dungeon.")
  10.     (if (file-exists? "dungeon.hnet")
  11.         (begin
  12.             ;load character
  13.             (fmt "Load saved game? " 0)
  14.             (let ((c (read)))
  15.                 (if (eq? c 'y)
  16.                     (let ((save (car (read-in "dungeon.hnet"))))
  17.                         ;(fmt "loaded " 0)
  18.                         ;(fmt save)
  19.                         (game-loop (car save) (cadr save) (caddr save) (cadr (cddr save)) 'new)
  20.                     )
  21.                     (delete-file "dungeon.hnet")
  22.                 )
  23.             )
  24.         )
  25.         (begin
  26.             ;create char
  27.             ;...
  28.             ;(fmt "New character:")
  29.             ;(set! player '("" () ()))
  30.             ;(fmt "Name: " 0)
  31.             ;(set! player (insert player 1 (list 'name (read))))
  32.             (fmt "You are a nameless servant of Dark, unchained from the curse of living.")
  33.             (fmt "Now go forward into the deep caverns!")
  34.             (fmt " ~~~ ")
  35.             (fmt "")
  36.             (game-loop starting-room starting-inventory starting-equipment starting-stats 'new)
  37.         )
  38.     )
  39. )
  40. (define (game-loop room inventory equipment stats . status)
  41.     (if debug-calls (fmt (list "game-loop " room " " inventory " " equipment " " stats)))
  42.     (if (not (null? status))
  43.         (if (eq? (car status) 'new)
  44.             (begin
  45.                 (fmt (cadr room))
  46.             )
  47.         )
  48.     )
  49.     (let ((enc-result (enc-loop (car room) inventory equipment stats)))
  50.         (if (not (null? enc-result))
  51.             (input-loop 0 room (elem enc-result 1) (elem enc-result 2) (elem enc-result 3))
  52.             ; the input-loop will call the game-loop when adequate
  53.             (begin
  54.                 (fmt "Game over.")
  55.                 (error "Your life force has run out.")
  56.             )
  57.         )
  58.     )
  59.     ;(game-loop room inventory equipment stats)
  60. )
  61. (define (enc-loop room-name inventory0 equipment0 stats0)
  62.     (if debug-calls (fmt "enc-loop"))
  63.     (if (is-visited room-name stats0)
  64.         (list inventory0 equipment0 stats0)
  65.         (let next-enc ((encs (room: 'encs room-name)) (inventory inventory0) (equipment equipment0) (stats stats0))
  66.             (if (null? encs)
  67.                 (list inventory equipment (add-to-visited room-name stats)) ;when all completed
  68.                 (begin
  69.                     (case (caar encs)
  70.                         ((fight)
  71.                             (let ((result (fight-enemy (cadar encs) inventory equipment stats)))
  72.                                 (if (< result 0)
  73.                                     (begin
  74.                                         (fmt " --- YOU DIED. ---")
  75.                                         '()
  76.                                     )
  77.                                     (begin
  78.                                         (fmt " --- You banished the enemy! The loot is yours!")
  79.                                         (next-enc (cdr encs) (loot-enemy (cadar encs) inventory) equipment stats)
  80.                                     )
  81.                                 )
  82.                             )
  83.                         )
  84.                         ((item)
  85.                             (fmt "Item found: " 0)
  86.                             (fmt (cadar encs))
  87.                             (next-enc (cdr encs) (add-to-inventory (cadar encs) inventory) equipment stats)
  88.                         )
  89.                     )
  90.                 )
  91.             )
  92.         )
  93.     )
  94. )
  95. (define (input-loop i room inventory equipment stats)
  96.     (if debug-calls (fmt "input-loop"))
  97.     (fmt "\ni: inventory | e: equipment | s: focus | g: move on")
  98.     (let ((c (read)))
  99.         (case c
  100.             ((i)
  101.                 (let ((inv (list-inventory inventory equipment)))
  102.                     (fmt inv)
  103.                     (if (< (length inv) 1)
  104.                         (fmt "Your inventory is empty. :-(")
  105.                         (begin
  106.                             (fmt "> Equip (cancel with 'n'): " 0)
  107.                             (let ((item-no (read)))
  108.                                 (if (number? item-no)
  109.                                     (if (is-equipped (elem inventory item-no) equipment)
  110.                                         (fmt "already equipped")
  111.                                         (begin
  112.                                             (input-loop 1 room inventory (equip-item (elem inventory item-no) equipment) stats)
  113.                                         )
  114.                                     )
  115.                                     (input-loop 1 room inventory equipment stats)
  116.                                 )
  117.                             )
  118.                         )
  119.                     )
  120.                 )
  121.             )
  122.             ((e)
  123.                 (let ((equip (list-equipment equipment)))
  124.                     (fmt equip)
  125.                 )
  126.             )
  127.             ((s)
  128.                 (let ((focus (stat: 'focus stats)))
  129.                     ;(fmt focus)
  130.                     (fmt "Focus on head area: " 0)
  131.                     (fmt (stat: 'head focus))
  132.                     (fmt "Focus on torso area: " 0)
  133.                     (fmt (stat: 'torso focus))
  134.                     (fmt "Focus on lateral area: " 0)
  135.                     (fmt (stat: 'arms focus))
  136.                     (fmt "Focus on leg area: " 0)
  137.                     (fmt (stat: 'legs focus))
  138.                     (fmt "You are not powerful enough to attune your focus.")
  139.                 )
  140.             )
  141.             ((g)
  142.                 (let g-loop ((rooms (list-doors room)))
  143.                     (fmt rooms)
  144.                     (fmt "> Go to room (cancel with 'n'): " 0)
  145.                     (let ((room-no (read)))
  146.                         (if (and (number? room-no) (< room-no (+ (length (room: 'doors (car room))) 1)))
  147.                             (let ((target-room (elem (room: 'doors (car room)) room-no)))
  148.                                 (if (room-unlocked target-room)
  149.                                     (begin
  150.                                         (fmt "going to " 0)
  151.                                         (fmt (cadr target-room))
  152.                                         (let ((room-status (if (is-visited (cadr target-room) stats) 'revisit 'new)))
  153.                                             (game-loop (room: 'all (cadr target-room)) inventory equipment stats room-status)
  154.                                         )
  155.                                     )
  156.                                     (begin
  157.                                         (fmt "This room requires the following key: " 0)
  158.                                         (let ((key (caddr target-room)))
  159.                                             (fmt key)
  160.                                             (if (contains inventory key)
  161.                                                 (begin
  162.                                                     (fmt "\n - Unlocking with " 0)
  163.                                                     (fmt key)
  164.                                                     (fmt "\n")
  165.                                                     (game-loop (room: 'all (cadr target-room)) inventory equipment stats 'new)
  166.                                                 )
  167.                                                 (g-loop rooms)
  168.                                             )
  169.                                         )
  170.                                     )
  171.                                 )
  172.                             )
  173.                             (if (eq? room-no 'n)
  174.                                 (input-loop 1 room inventory equipment stats)
  175.                                 (begin
  176.                                     (fmt " > Type one of the given numbers, or 'n' to cancel.")
  177.                                     (g-loop rooms) ;retry for good input
  178.                                 )
  179.                             )
  180.                         )
  181.                     )
  182.                 )
  183.             )
  184.             ((save)
  185.                 (fmt "Saving data..." 0)
  186.                 (write-out
  187.                     "dungeon.hnet"
  188.                     (list room inventory equipment stats)
  189.                 )
  190.                 (fmt "done.")
  191.             )
  192.             ;(else (input-loop 1 room inventory equipment stats))
  193.         )
  194.     )
  195.     (input-loop 1 room inventory equipment stats)
  196. )
  197.  
  198. ;;; Gegenstände
  199. (define items (load "dungeon-items.scm"))
  200.  
  201. (define starting-inventory
  202. '(
  203.     "Rusted Karak"
  204. ))
  205.  
  206. (define starting-equipment
  207. '(
  208.     (weapon "Bare Fists")
  209.     (shield "Nothing")
  210.     (head "Nothing")
  211.     (torso "Nothing")
  212.     (arms "Nothing")
  213.     (hands "Nothing")
  214.     (legs "Nothing")
  215.     (feet "Nothing")
  216.     (left-finger "Nothing")
  217.     (right-finger "Nothing")
  218.     (neck "Nothing")
  219. ))
  220.  
  221. (define (item: x name)
  222.     ; Retrieve information (x) about an item by its name
  223.     (if debug-calls (fmt (list "item: " x " " name)))
  224.     (let cont ((l items))
  225.         (if (or (not name) (null? l))
  226.             '!!!item-not-listed!!!
  227.             (if (string=? (caar l) name)
  228.                 (if (eq? x 'all)
  229.                     (car l)
  230.                     (elem (car l) (case x ((description) 2) ((type) 3) ((stat damage armor) 4)))
  231.                 )
  232.                 (cont (cdr l))
  233.             )
  234.         )
  235.     )
  236. )
  237. (define (add-to-inventory item-name inventory)
  238.     (if debug-calls (fmt (list "add-to-inv " item-name " " inventory)))
  239.     (append inventory (list item-name))
  240. )
  241. (define (list-inventory inv equipment . li)
  242.     (if debug-calls (fmt (list "list-inv " inv " " li)))
  243.     (if (null? inv)
  244.         '()
  245.         (cons
  246.             (string-append
  247.                 "" (number->string (if (null? li) 1 (car li))) ": "
  248.                 (car inv)
  249.                 (if (is-equipped (car inv) equipment)
  250.                     (string-append
  251.                         "  {equipped as "
  252.                         (symbol->string (item: 'type (car inv)))
  253.                         "} "
  254.                     )
  255.                     (string-append
  256.                         " => "
  257.                         (let ((comp (compare-to-equipped-item (car inv) equipment)))
  258.                             (if (> comp 0)
  259.                                 (string-append "+" (number->string comp))
  260.                                 (number->string comp)
  261.                             )
  262.                         )
  263.                     )
  264.                 )
  265.                 "\n"
  266.             )
  267.             (list-inventory (cdr inv) equipment (if (null? li) 2 (+ (car li) 1)))
  268.         )
  269.     )
  270. )
  271.  
  272. (define (equip-item item-name equipment)
  273.     (if debug-calls (fmt (list "equip " item-name)))
  274.     (let cont ((l equipment))
  275.         (if (null? l)
  276.             '()
  277.             (if (eq? (caar l) (item: 'type item-name))
  278.                 (begin
  279.                     (fmt "equipped " 0)
  280.                     (fmt item-name)
  281.                     (cons (list (caar l) item-name) (cont (cdr l)))
  282.                 )
  283.                 (cons (car l) (cont (cdr l)))
  284.             )
  285.         )
  286.     )
  287. )
  288. (define (is-equipped name equipment)
  289.     (if debug-calls (fmt (list "is-equipped " name)))
  290.     (eqv?
  291.         (item-in-slot (item: 'type name) equipment)
  292.         name
  293.     )
  294. )
  295. (define (compare-to-equipped-item item-name equipment)
  296.     (if debug-calls (fmt (list "compare-item " item-name)))
  297.     (-
  298.         (item: 'stat item-name)
  299.         (let ((equipped-item-name (item-in-slot (item: 'type item-name) equipment)))
  300.             (if equipped-item-name
  301.                 (item: 'stat equipped-item-name)
  302.                 0
  303.             )
  304.         )
  305.     )
  306. )
  307. (define (item-in-slot slot equipment)
  308.     (if debug-calls (fmt (list "item-in-slot " slot)))
  309.     (let cont ((l equipment))
  310.         (if (null? l)
  311.             "Nothing"
  312.             (if (eq? slot (caar l))
  313.                 (if (cadar l)
  314.                     (cadar l)
  315.                     "Nothing"
  316.                 )
  317.                 (cont (cdr l))
  318.             )
  319.         )
  320.     )
  321. )
  322. (define (list-equipment equipment)
  323.     (if debug-calls (fmt (list "list-equipment")))
  324.     (let cont ((l equipment))
  325.         (if (null? l)
  326.             '()
  327.             (cons
  328.                 (string-append
  329.                     (symbol->string (caar l)) " : "
  330.                     (if (cadar l)
  331.                         (string-append
  332.                             (cadar l) "   "
  333.                             (number->string (item: 'stat (cadar l)))
  334.                         )
  335.                         "(empty)")
  336.                     "\n"
  337.                 )
  338.                 (cont (cdr l))
  339.             )
  340.         )
  341.     )
  342. )
  343.  
  344. ;;; Räume
  345. (define rooms (load "dungeon-rooms.scm"))
  346. (define starting-room (elem rooms 1))
  347.  
  348. (define (list-doors room)
  349.     (if debug-calls (fmt (list "list-doors " room)))
  350.     (let cont ((l (room: 'doors (car room))) (li 1))
  351.         (if (null? l)
  352.             '()
  353.             (cons
  354.                 (string-append
  355.                     "" (number->string li) ": "
  356.                     (cadar l)
  357.                     (case (caar l)
  358.                         ((open) "   (open) ")
  359.                         ((jammed) "   [Jammed!] ")
  360.                         ((locked) (string-append "   [locked: " (cadr (cdar l)) "] "))
  361.                     )
  362.                     "\n"
  363.                 )
  364.                 (cont (cdr l) (+ li 1))
  365.             )
  366.         )
  367.     )
  368. )
  369. (define (room: x name)
  370.     (if debug-calls (fmt (list "room: " x " " name)))
  371.     (let cont ((l rooms))
  372.         ;(fmt (cadr (cdar l)))
  373.         (if (null? l)
  374.             '!!!given-room-not-defined!!!
  375.             (if (string=? (caar l) name)
  376.                 (begin
  377.                     (case x
  378.                         ((all) (car l))
  379.                         ((description) (cadr l))
  380.                         ((enc encs encounters items actions) (cadr (cdar l)))
  381.                         ((doors) (cadr (cddar l)))
  382.                     )
  383.                 )
  384.                 (cont (cdr l))
  385.             )
  386.         )
  387.     )
  388. )
  389. (define (room-unlocked door)
  390.     (eq? (car door) 'open)
  391. )
  392. (define (add-to-visited room-name stats)
  393.     (if debug-calls (fmt (list "add-to-visited " room-name " " stats)))
  394.     (if (null? stats)
  395.         '()
  396.         (if (eq? (caar stats) 'visited)
  397.             (cons (list (caar stats) (append (cadar stats) (list room-name))) (add-to-visited room-name (cdr stats)))
  398.             (cons (car stats) (add-to-visited room-name (cdr stats)))
  399.         )
  400.     )
  401. )
  402. (define (is-visited room-name stats)
  403.     (if debug-calls (fmt (list "is-visited " room-name " " stats)))
  404.     (contains (stat: 'visited stats) room-name)
  405. )
  406.  
  407. ;;; Spieler-Charakter
  408. (define player
  409.     '()
  410. )
  411. (define starting-stats
  412. '(
  413.     (life 800)
  414.     (strength 4)
  415.     (agility 5)
  416.     (faith 1)
  417.     (focus (
  418.         (torso 0.4)
  419.         (arms 0.3)
  420.         (legs 0.2)
  421.         (head 0.1)
  422.         )
  423.     )
  424.     (visited ())
  425. ))
  426. (define (stat: x stat-list)
  427.     (if debug-calls (fmt (list "stat: " x " " stat-list)))
  428.     (if (null? stat-list)
  429.         0
  430.         (if (eq? (caar stat-list) x)
  431.             (cadar stat-list)
  432.             (stat: x (cdr stat-list))
  433.         )
  434.     )
  435. )
  436.  
  437. ;;; Gegner
  438. (define encounters (load "dungeon-enc.scm"))
  439.  
  440. (define (fight-enemy enemy-name inventory equipment stats)
  441.     (fmt "FIGHT: " 0)
  442.     (fmt enemy-name)
  443.     (let fight
  444.         ((round 1) (my-hp 800) (enemy-hp (enemy: 'hp enemy-name))
  445.             (enemy-equipment (enemy: 'equipment enemy-name))
  446.             (enemy-stats (enemy: 'stats enemy-name))
  447.         )
  448.         (if (or (< my-hp 0) (< enemy-hp 0))
  449.             my-hp
  450.             (let* (
  451.                     (my-area (~attack-area stats))
  452.                     (my-attack (effective-damage my-area stats equipment enemy-equipment))
  453.                     (enemy-area (~attack-area enemy-stats))
  454.                     (enemy-attack (effective-damage enemy-area enemy-stats enemy-equipment equipment))
  455.                 )
  456.                 (fmt "You strike the enemy for " 0)
  457.                 (fmt my-attack 0)
  458.                 (fmt " damage! (" 0)
  459.                 (fmt my-area 0)
  460.                 (fmt ")")
  461.                 (fmt "You get hit for " 0)
  462.                 (fmt enemy-attack 0)
  463.                 (fmt " damage! (" 0)
  464.                 (fmt enemy-area 0)
  465.                 (fmt ")")
  466.                 (fmt "[ HP: " 0)
  467.                 (fmt my-hp 0)
  468.                 (fmt " ] ")
  469.                 (fight (+ round 1) (- my-hp enemy-attack) (- enemy-hp my-attack) enemy-equipment enemy-stats)
  470.             )
  471.         )
  472.     )
  473. )
  474. (define (effective-damage attack-area src-stats src-equipment dest-equipment)
  475.     (let* (;old: (attack-area (~attack-area src-stats))
  476.         (result
  477.             (- 
  478.                 (*
  479.                     (stat: 'strength src-stats)
  480.                     (item: 'damage (item-in-slot 'weapon src-equipment))
  481.                     (area-effect attack-area)
  482.                 )
  483.                 (item: 'armor (item-in-slot attack-area dest-equipment))
  484.             )
  485.         ))
  486.         (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)) "]")))
  487.         (if (< result 0) 0 result)
  488.     )
  489. )
  490. (define (~attack-area stats)
  491.     (let ((focus (stat: 'focus stats)))
  492.         (if (list? focus)
  493.             ; todo: choose random area according to focus
  494.             (car (list-ref focus (random (length focus))))
  495.             'torso
  496.         )
  497.     )
  498. )
  499. (define (area-effect attacked-area)
  500.     (case attacked-area
  501.         ((head) 4.0)
  502.         ((torso) 1.0)
  503.         ((arms) 0.2)
  504.         ((legs) 0.15)
  505.     )
  506. )
  507. (define (loot-enemy enemy-name player-inventory)
  508.     (if debug-calls (fmt (list "loot-enemy " enemy-name)))
  509.     (let step ((items (enemy: 'items enemy-name)) (inv player-inventory))
  510.         (if (null? items)
  511.             inv
  512.             (let ((ci (cadar items)))
  513.                 (fmt "You found: " 0)
  514.                 (fmt ci)
  515.                 (step (cdr items) (add-to-inventory ci inv))
  516.             )
  517.         )  
  518.     )
  519. )
  520. (define (enemy: x name)
  521.     (if debug-calls (fmt (list "enemy: " x " " name)))
  522.     (let cont ((l encounters))
  523.         (if (null? l)
  524.             #f
  525.             (if (string=? (caar l) name)
  526.                 (case x
  527.                     ((type) (elem (car l) 2))
  528.                     ((stats) (elem (car l) 3))
  529.                     ((hp) (stat: 'hp (elem (car l) 3)))
  530.                     ((equipment items) (elem (car l) 4))
  531.                 )
  532.                 (cont (cdr l))
  533.             )
  534.         )
  535.     )
  536. )
  537.  
  538. (load "resource-bundle.scm")
  539. (start)
  540.  
  541. (define enemy-titles
  542.     (list
  543.         "Slave" "Bruiser" "Headhunter" "Swordmaster" "Enchanter" "Travelling Knight"
  544.         "Ascended Blademaster" "Mystic Aircaster" "Ancient Brute" "Sanctified Knight"
  545.         "Nocturnal Master" "Dungeon Hero"
  546.     )
  547. )
RAW Paste Data