├── .gitignore ├── Spell.elm ├── Configuration.elm ├── ChallengeRating.elm ├── elm-package.json ├── Liquid.elm ├── README.md ├── Helm.elm ├── Journal.elm ├── Idea.elm ├── Log.elm ├── Armor.elm ├── Optics.elm ├── Status.elm ├── Bresenham.elm ├── Direction.elm ├── Ring.elm ├── Graphics.elm ├── Quest.elm ├── Species.elm ├── Creature.elm ├── Language.elm ├── Event.elm ├── Weapon.elm ├── Palette.elm ├── Path.elm ├── Dungeon.elm ├── Point.elm ├── Util.elm ├── Graph.elm ├── Item.elm ├── Action.elm ├── Entity.elm ├── Inventory.elm ├── Room.elm ├── game.elm ├── Warrior.elm ├── World.elm ├── Level.elm └── Engine.elm /.gitignore: -------------------------------------------------------------------------------- 1 | elm-stuff 2 | -------------------------------------------------------------------------------- /Spell.elm: -------------------------------------------------------------------------------- 1 | module Spell exposing (Spell(..), idea, lux, infuse) 2 | 3 | import Idea exposing (Idea) 4 | 5 | type Spell = Lux 6 | | Infuse 7 | 8 | lux = 9 | Lux 10 | 11 | infuse = 12 | Infuse 13 | 14 | idea : Spell -> Idea 15 | idea spell = 16 | case spell of 17 | Lux -> 18 | Idea.light 19 | 20 | Infuse -> 21 | Idea.power 22 | -------------------------------------------------------------------------------- /Configuration.elm: -------------------------------------------------------------------------------- 1 | module Configuration exposing (levelCount, tickInterval, visionRadius, inventoryLimit, maxRoomWidth, maxRoomHeight, startingHitPoints, startingStrength, candidateRooms, viewWidth, viewHeight) 2 | 3 | import Time exposing (Time, millisecond) 4 | 5 | tickInterval = 25*millisecond 6 | levelCount = 10 7 | 8 | --viewScale = 16 9 | viewWidth = 60 10 | viewHeight = 40 11 | 12 | -- dungeon 13 | candidateRooms = 500 14 | maxRoomWidth = 14 15 | maxRoomHeight = 10 16 | 17 | -- character 18 | visionRadius = 4 19 | inventoryLimit = 14 20 | startingHitPoints = 35 21 | startingStrength = 5 22 | -------------------------------------------------------------------------------- /ChallengeRating.elm: -------------------------------------------------------------------------------- 1 | module ChallengeRating exposing (ChallengeRating(..), forDepth) 2 | 3 | import Configuration exposing (levelCount) 4 | 5 | type ChallengeRating = Beginner 6 | | Easy 7 | | Moderate 8 | | Hard 9 | | Impossible 10 | 11 | 12 | forDepth : Int -> ChallengeRating 13 | forDepth level = 14 | if level < levelCount // 5 then 15 | Beginner 16 | else if level < 2 * levelCount // 5 then 17 | Easy 18 | else if level < 3 * levelCount // 5 then 19 | Moderate 20 | else if level < 4 * (levelCount // 5) then 21 | Hard 22 | else 23 | Impossible 24 | -------------------------------------------------------------------------------- /elm-package.json: -------------------------------------------------------------------------------- 1 | { 2 | "version": "1.0.0", 3 | "summary": "simple rogue clone", 4 | "repository": "https://github.com/jweissman/rogue.git", 5 | "license": "MIT", 6 | "source-directories": [ 7 | "." 8 | ], 9 | "exposed-modules": [], 10 | "dependencies": { 11 | "elm-lang/core": "4.0.3 <= v < 5.0.0", 12 | "elm-lang/html": "1.1.0 <= v < 2.0.0", 13 | "elm-lang/keyboard": "1.0.0 <= v < 2.0.0", 14 | "elm-lang/mouse": "1.0.0 <= v < 2.0.0", 15 | "elm-lang/svg": "1.1.1 <= v < 2.0.0", 16 | "elm-lang/window": "1.0.0 <= v < 2.0.0" 17 | }, 18 | "elm-version": "0.17.1 <= v < 0.18.0" 19 | } 20 | -------------------------------------------------------------------------------- /Liquid.elm: -------------------------------------------------------------------------------- 1 | module Liquid exposing (Liquid(..), Effect(..), idea, water, lifePotion, holyWater) 2 | 3 | import Idea exposing (Idea) 4 | 5 | type Effect = GainLife 6 | 7 | type Liquid = Water 8 | | Blessed Liquid 9 | | Potion Effect 10 | 11 | water = 12 | Water 13 | 14 | holy liquid = 15 | Blessed liquid 16 | 17 | lifePotion = 18 | Potion GainLife 19 | 20 | holyWater = 21 | Blessed Water 22 | 23 | idea : Liquid -> Idea 24 | idea liquid = 25 | case liquid of 26 | Water -> 27 | Idea.water 28 | 29 | Blessed liquid' -> 30 | Idea.compound [Idea.holy, (idea liquid')] 31 | 32 | Potion effect -> 33 | case effect of 34 | GainLife -> 35 | Idea.life 36 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # mandos 2 | 3 | a tiny rogue clone written in elm! 4 | 5 | # about 6 | 7 | this is a learning elm project but i'd also like the code to be clear and well-factored enough to be a "teaching" project as well 8 | 9 | # features 10 | 11 | - [x] armor 12 | - [x] auto-explore 13 | - [x] event log 14 | - [x] field of vision 15 | - [x] items 16 | - [x] language 17 | - [x] map generation 18 | - [x] melee combat 19 | - [x] quest journal 20 | - [x] weapons 21 | - [ ] responsive 22 | - [ ] thrown weapons 23 | - [ ] env hazards (water/lava features) 24 | - [ ] allies 25 | - [ ] history (statues, engravings, monoliths) 26 | 27 | # caveats 28 | 29 | known not to work in firefox (this is maybe an `elm-keyboard` issue?) 30 | -------------------------------------------------------------------------------- /Helm.elm: -------------------------------------------------------------------------------- 1 | module Helm exposing (Helm, describe, absorption, enchant, cap, helmet) 2 | 3 | type Helm = Cap 4 | | Helmet 5 | | Enchanted Int Helm 6 | 7 | cap : Helm 8 | cap = 9 | Cap 10 | 11 | helmet : Helm 12 | helmet = 13 | Helmet 14 | 15 | describe : Helm -> String 16 | describe helm = 17 | case helm of 18 | Cap -> 19 | "cap" 20 | 21 | Helmet -> 22 | "helmet" 23 | 24 | Enchanted n helm' -> 25 | "+" ++ (toString n) ++ " " ++ describe helm' 26 | 27 | enchant : Helm -> Helm 28 | enchant helm = 29 | case helm of 30 | Enchanted n helm' -> 31 | Enchanted (n+1) helm' 32 | 33 | _ -> 34 | Enchanted 1 helm 35 | 36 | absorption : Helm -> Int 37 | absorption helm = 38 | case helm of 39 | Cap -> 40 | 1 41 | 42 | Helmet -> 43 | 2 44 | 45 | Enchanted n helm' -> 46 | n + absorption helm' 47 | -------------------------------------------------------------------------------- /Journal.elm: -------------------------------------------------------------------------------- 1 | module Journal exposing (Journal, view) 2 | 3 | import Point exposing (Point) 4 | import Quest exposing (Quest) 5 | import World 6 | import Graphics 7 | import Palette 8 | 9 | import Svg 10 | 11 | type alias Journal = List Quest 12 | 13 | view : Point -> World.Model -> List Quest -> List (Svg.Svg a) 14 | view (x,y) world quests = 15 | let 16 | (completed, active) = 17 | quests 18 | |> List.partition (Quest.completed world) 19 | 20 | completed' = 21 | quests 22 | 23 | title = 24 | (Graphics.render "QUESTS" (x,y) Palette.tertiaryLighter) 25 | in 26 | title :: 27 | (questGroupView (x,y+1) active "[ ]" Palette.active) ++ 28 | (questGroupView (x,y+1+(List.length active)) completed "[x]" Palette.inactive) 29 | 30 | questGroupView (x,y) quests prefix color = 31 | (quests 32 | |> List.indexedMap (\idx q -> 33 | Graphics.render (prefix ++ " " ++ Quest.describe q) (x,y+1+idx) color)) 34 | -------------------------------------------------------------------------------- /Idea.elm: -------------------------------------------------------------------------------- 1 | module Idea exposing (Idea, describe, ideas, light, power, water, compound, holy, life) 2 | 3 | import String 4 | 5 | type Idea = Power 6 | | Light 7 | | Life 8 | | Water 9 | | Holy 10 | --| Imagination 11 | | Compound (List Idea) 12 | 13 | light = 14 | Light 15 | 16 | life = 17 | Life 18 | 19 | power = 20 | Power 21 | 22 | water = 23 | Water 24 | 25 | holy = 26 | Holy 27 | 28 | compound is = 29 | Compound is 30 | 31 | ideas = 32 | [ Power 33 | , Light 34 | , Life 35 | , Water 36 | , Holy 37 | , Compound [Holy, Water] 38 | ] 39 | 40 | describe : Idea -> String 41 | describe idea = 42 | case idea of 43 | Power -> 44 | "power" 45 | 46 | Light -> 47 | "light" 48 | 49 | Life -> 50 | "life" 51 | 52 | Water -> 53 | "water" 54 | 55 | Holy -> 56 | "holy" 57 | 58 | Compound ideas -> 59 | ideas 60 | |> List.map describe 61 | |> String.join " " 62 | -------------------------------------------------------------------------------- /Log.elm: -------------------------------------------------------------------------------- 1 | module Log exposing (Model, init, view) 2 | 3 | import Creature 4 | import Event exposing (Event) 5 | import Point exposing (Point) 6 | import Graphics 7 | import Palette 8 | import Language exposing (Language) 9 | 10 | import Svg 11 | 12 | -- MODEL 13 | type alias Model = List Event 14 | 15 | -- INIT 16 | init : Model 17 | init = [ Event.awaken ] 18 | 19 | maxEntries = 7 20 | 21 | -- VIEW 22 | view : Point -> Language -> Language -> List Event -> List (Svg.Svg a) 23 | view origin vocab lang model = 24 | let 25 | notes = 26 | List.take maxEntries (List.reverse (List.map (Event.describe vocab lang) model)) 27 | 28 | logLines = 29 | List.indexedMap (logLineView origin) notes 30 | 31 | header = 32 | Graphics.render "EVENTS" origin "white" 33 | 34 | in 35 | [header] ++ logLines 36 | 37 | logLineView : Point -> Int -> String -> Svg.Svg a 38 | logLineView origin idx note = 39 | let (ox,oy) = origin in 40 | Graphics.render note (ox,oy+1+idx) (Palette.rgb (Palette.blue idx)) 41 | -------------------------------------------------------------------------------- /Armor.elm: -------------------------------------------------------------------------------- 1 | module Armor exposing (Armor, absorption, describe, tunic, suit, plate, enchant) 2 | 3 | import String 4 | 5 | type Armor = Suit 6 | | Tunic 7 | | Plate 8 | | Enchanted Int Armor 9 | 10 | tunic : Armor 11 | tunic = 12 | Tunic 13 | 14 | suit : Armor 15 | suit = 16 | Suit 17 | 18 | plate : Armor 19 | plate = 20 | Plate 21 | 22 | enchant : Armor -> Armor 23 | enchant armor = 24 | case armor of 25 | Enchanted n armor' -> 26 | Enchanted (n+1) armor' 27 | 28 | _ -> 29 | Enchanted 1 armor 30 | 31 | absorption : Armor -> Int 32 | absorption armor = 33 | case armor of 34 | Tunic -> 35 | 2 36 | 37 | Suit -> 38 | 5 39 | 40 | Plate -> 41 | 7 42 | 43 | Enchanted n armor' -> 44 | n + absorption armor' 45 | 46 | describe : Armor -> String 47 | describe armor = 48 | case armor of 49 | Suit -> 50 | "suit" 51 | 52 | Tunic -> 53 | "tunic" 54 | 55 | Plate -> 56 | "plate" 57 | 58 | Enchanted n armor' -> 59 | "+" ++ (toString n) ++ " " ++ describe armor' 60 | -------------------------------------------------------------------------------- /Optics.elm: -------------------------------------------------------------------------------- 1 | module Optics exposing (illuminate, castRay) 2 | 3 | import Set exposing (Set) 4 | import Point exposing (Point, code) 5 | import Util 6 | import Bresenham exposing (line) 7 | import Configuration 8 | 9 | illuminate : Int -> List Point -> Set Point -> Point -> Set Point 10 | illuminate power perimeter blockers source = 11 | let 12 | rays = 13 | castRay power blockers source 14 | in 15 | perimeter 16 | |> List.concatMap rays 17 | |> Set.fromList 18 | 19 | castRay : Int -> Set Point -> Point -> Point -> List Point 20 | castRay power blockers src dst = 21 | let 22 | pts = 23 | line src dst 24 | |> List.tail 25 | |> Maybe.withDefault [] 26 | 27 | notAbsorbed = \pt -> 28 | not (Set.member pt blockers) 29 | && not ((Point.distance src pt) > toFloat power) 30 | 31 | in 32 | pts 33 | |> takeWhile' notAbsorbed 34 | 35 | takeWhile' : (a -> Bool) -> List a -> List a 36 | takeWhile' predicate list = 37 | case list of 38 | [] -> [] 39 | x::xs -> if (predicate x) then x :: takeWhile' predicate xs 40 | else [x] 41 | -------------------------------------------------------------------------------- /Status.elm: -------------------------------------------------------------------------------- 1 | module Status exposing (view) 2 | 3 | import World 4 | import Graphics 5 | import Point exposing (Point) 6 | import Palette 7 | 8 | import String 9 | import Svg 10 | 11 | view : Point -> World.Model -> List (Svg.Svg a) 12 | view (x,y) model = 13 | let 14 | level = 15 | levelView (x,y) model.depth 16 | 17 | gold = 18 | goldView (x+5,y) model.player.gold 19 | 20 | life = 21 | lifeView (x+10,y) model.player.hp model.player.maxHp 22 | in 23 | level 24 | ++ gold 25 | ++ life 26 | 27 | levelView : Point -> Int -> List (Svg.Svg a) 28 | levelView (x,y) depth = 29 | [ Graphics.render "LEVEL" (x,y) Palette.primaryLighter 30 | , Graphics.render (toString (depth+1)) (x+3,y) Palette.bright 31 | ] 32 | 33 | goldView : Point -> Int -> List (Svg.Svg a) 34 | goldView (x,y) amt = 35 | [ Graphics.render "GOLD" (x,y) Palette.secondaryLighter 36 | , Graphics.render ((toString amt) ++ "p") (x+3,y) Palette.bright 37 | ] 38 | 39 | lifeView : Point -> Int -> Int -> List (Svg.Svg a) 40 | lifeView (x,y) hp maxHp = 41 | [ Graphics.render "LIFE" (x,y) Palette.accentLighter 42 | , Graphics.render (toString hp) (x+3,y) Palette.bright 43 | , Graphics.render "/" (x+4,y) Palette.bright 44 | , Graphics.render (toString maxHp) (x+5,y) Palette.bright 45 | ] 46 | -------------------------------------------------------------------------------- /Bresenham.elm: -------------------------------------------------------------------------------- 1 | module Bresenham exposing (line) 2 | 3 | import Point exposing (Point) 4 | 5 | line : Point -> Point -> List Point 6 | line (ax,ay) (bx,by) = 7 | if ax == bx then 8 | vline ax ay by 9 | else if ay == by then 10 | hline ay ax bx 11 | else 12 | line' (ax,ay) (bx,by) 13 | 14 | vline : Int -> Int -> Int -> List Point 15 | vline x y0 y1 = 16 | if y1 < y0 then 17 | List.reverse (vline x y1 y0) 18 | else 19 | List.map (\y -> (x,y)) [y0..y1] 20 | 21 | hline : Int -> Int -> Int -> List Point 22 | hline y x0 x1 = 23 | if x1 < x0 then 24 | List.reverse (hline y x1 x0) 25 | else 26 | List.map (\x -> (x,y)) [x0..x1] 27 | 28 | line' : Point -> Point -> List Point 29 | line' (ax,ay) (bx,by) = 30 | let 31 | dy = 32 | toFloat (by - ay) 33 | dx = 34 | toFloat (bx - ax) 35 | in 36 | 37 | if abs dx > abs dy then 38 | let 39 | f = \x -> 40 | slope * toFloat (x - ax) 41 | 42 | slope = 43 | dy / dx 44 | in 45 | if ax > bx then 46 | List.reverse (line' (bx,by) (ax,ay)) 47 | else 48 | [ax..bx] 49 | |> List.map (\x -> (x, round (f x) + ay)) 50 | else 51 | let 52 | f = \y -> 53 | slope * toFloat (y - ay) 54 | 55 | slope = 56 | dx / dy 57 | in 58 | if ay > by then 59 | List.reverse (line' (bx,by) (ax,ay)) 60 | else 61 | [(ay)..(by)] 62 | |> List.map (\y -> (round (f y) + ax, y)) 63 | -------------------------------------------------------------------------------- /Direction.elm: -------------------------------------------------------------------------------- 1 | module Direction exposing (Direction(..), random, describe, invert, directions, cardinalDirections) 2 | 3 | import Random 4 | 5 | type Direction = North 6 | | South 7 | | East 8 | | West 9 | | Northeast 10 | | Northwest 11 | | Southeast 12 | | Southwest 13 | 14 | 15 | cardinalDirections : List Direction 16 | cardinalDirections = 17 | [ North 18 | , South 19 | , East 20 | , West 21 | ] 22 | 23 | 24 | directions : List Direction 25 | directions = 26 | cardinalDirections ++ 27 | [ Northeast 28 | , Northwest 29 | , Southeast 30 | , Southwest 31 | ] 32 | 33 | random : Random.Generator Direction 34 | random = 35 | Random.map (\i -> 36 | case i of 37 | 0 -> South 38 | 1 -> North 39 | 2 -> East 40 | 3 -> West 41 | 4 -> Northwest 42 | 5 -> Northeast 43 | 6 -> Southwest 44 | _ -> Southeast 45 | ) (Random.int 0 7) 46 | 47 | describe : Direction -> String 48 | describe direction = 49 | case direction of 50 | North -> "north" 51 | South -> "south" 52 | East -> "east" 53 | West -> "west" 54 | Northeast -> "northeast" 55 | Northwest -> "northwest" 56 | Southeast -> "southeast" 57 | Southwest -> "southwest" 58 | 59 | invert : Direction -> Direction 60 | invert direction = 61 | case direction of 62 | North -> South 63 | South -> North 64 | East -> West 65 | West -> East 66 | Northeast -> Southwest 67 | Northwest -> Southeast 68 | Southwest -> Northeast 69 | Southeast -> Northwest 70 | -------------------------------------------------------------------------------- /Ring.elm: -------------------------------------------------------------------------------- 1 | module Ring exposing (Ring, describe, spell, enchant, light, power, strengthBonus, visionBonus) 2 | 3 | import Spell exposing (Spell) 4 | import Language exposing (Language) 5 | 6 | type Ring = Annulus Spell 7 | | Enchanted Int Ring 8 | 9 | light : Ring 10 | light = 11 | Annulus Spell.lux 12 | 13 | power : Ring 14 | power = 15 | Annulus Spell.infuse 16 | 17 | spell : Ring -> Spell 18 | spell ring = 19 | case ring of 20 | Annulus spell' -> 21 | spell' 22 | 23 | Enchanted _ ring' -> 24 | spell ring' 25 | 26 | describe : Language -> Language -> Ring -> String 27 | describe vocab language ring = 28 | case ring of 29 | Annulus spell' -> 30 | "ring of " ++ (Language.decode (Spell.idea spell') vocab language) 31 | 32 | Enchanted n ring' -> 33 | "+" ++ (toString n) ++ " " ++ (describe vocab language ring') 34 | 35 | enchant : Ring -> Ring 36 | enchant ring = 37 | case ring of 38 | Enchanted n ring' -> 39 | Enchanted (n+1) ring' 40 | 41 | _ -> 42 | Enchanted 1 ring 43 | 44 | strengthBonus : Ring -> Int 45 | strengthBonus ring = 46 | case ring of 47 | Enchanted n ring' -> 48 | n * (strengthBonus ring') 49 | 50 | Annulus spell' -> 51 | case spell' of 52 | Spell.Lux -> 53 | 0 54 | 55 | Spell.Infuse -> 56 | 1 57 | 58 | visionBonus : Ring -> Int 59 | visionBonus ring = 60 | case ring of 61 | Enchanted n ring' -> 62 | n * (visionBonus ring') 63 | 64 | Annulus spell' -> 65 | case spell' of 66 | Spell.Lux -> 67 | 1 68 | 69 | Spell.Infuse -> 70 | 0 71 | -------------------------------------------------------------------------------- /Graphics.elm: -------------------------------------------------------------------------------- 1 | module Graphics exposing (render, hero, jumbo) 2 | 3 | import Point 4 | import Palette 5 | import Configuration 6 | 7 | import Html 8 | import Svg exposing (text') 9 | import Svg.Attributes exposing (x, y, fontSize, fontFamily, fill, textAnchor, dominantBaseline) 10 | 11 | font = "VT323" 12 | 13 | render : String -> Point.Point -> String -> Svg.Svg a 14 | render string (px,py) color = 15 | text' [ x (toString px) 16 | , y (toString py) 17 | , fontSize "1" 18 | , fontFamily font 19 | , fill color 20 | ] [ Html.text string ] 21 | 22 | render' : String -> Point.Point -> String -> String -> Svg.Svg a 23 | render' string (px,py) color anchor = 24 | text' [ x (toString px) 25 | , y (toString py) 26 | , fontSize "1" 27 | , fontFamily font 28 | , fill color 29 | , textAnchor anchor 30 | ] [ Html.text string ] 31 | 32 | verticalCenter = 33 | Configuration.viewWidth//2 34 | 35 | horizontalCenter = 36 | Configuration.viewHeight//2 37 | 38 | hero : String -> Int -> Svg.Svg a 39 | hero string py = -- (px,py) = 40 | text' [ x (toString verticalCenter) 41 | , y (toString py) 42 | , fontSize "16" 43 | , fontFamily font 44 | , fill Palette.bright 45 | , textAnchor "middle" 46 | ] [ Html.text string ] 47 | 48 | jumbo : String -> Svg.Svg a 49 | jumbo string = --(px,py) = 50 | text' [ x (toString verticalCenter) --(Configuration.viewWidth//2)) 51 | , y (toString (horizontalCenter//4)) 52 | , fontSize "60" 53 | , fontFamily font 54 | , fill (Palette.primary' 2 0.4) 55 | , textAnchor "middle" 56 | , dominantBaseline "hanging" 57 | ] [ Html.text string ] 58 | -------------------------------------------------------------------------------- /Quest.elm: -------------------------------------------------------------------------------- 1 | module Quest exposing (Quest, completed, describe, findCrystal, escape, goal, unlocked, coreCampaign) 2 | 3 | import World 4 | import Configuration 5 | 6 | type Goal = FindWeapon 7 | | FindArmor 8 | | FindCrystal 9 | | Escape 10 | 11 | type Quest = Quest Goal (List Quest) 12 | 13 | coreCampaign : List Quest 14 | coreCampaign = 15 | [ findWeapon ] 16 | 17 | findWeapon : Quest 18 | findWeapon = 19 | Quest FindWeapon [ findArmor ] 20 | 21 | findArmor : Quest 22 | findArmor = 23 | Quest FindArmor [ findCrystal ] 24 | 25 | findCrystal : Quest 26 | findCrystal = 27 | Quest FindCrystal [ escape ] 28 | 29 | escape : Quest 30 | escape = 31 | Quest Escape [] 32 | 33 | goal : Quest -> Goal 34 | goal (Quest goal' _) = goal' 35 | 36 | describe : Quest -> String 37 | describe (Quest goal _) = 38 | case goal of 39 | FindWeapon -> 40 | "Get a weapon" 41 | 42 | FindArmor -> 43 | "Put on some armor" 44 | 45 | FindCrystal -> 46 | "Seek the Crystal" 47 | 48 | Escape -> 49 | "Escape the Halls" 50 | 51 | completed : World.Model -> Quest -> Bool 52 | completed world (Quest goal _) = 53 | case goal of 54 | FindCrystal -> 55 | world |> World.doesPlayerHaveCrystal 56 | 57 | Escape -> 58 | world.hallsEscaped 59 | 60 | FindWeapon -> 61 | not (world.player.weapon == Nothing) 62 | 63 | FindArmor -> 64 | not (world.player.armor == Nothing) 65 | 66 | unlocked : World.Model -> List Quest -> List Quest 67 | unlocked world quests = 68 | let 69 | (completed', incomplete) = 70 | quests 71 | |> List.partition (completed world) 72 | 73 | unlocked' = 74 | completed' 75 | |> List.concatMap (\(Quest _ unlocks) -> unlocks) 76 | |> List.filter (\(Quest goal' _) -> 77 | not (List.member goal' (List.map goal quests))) 78 | in 79 | unlocked' 80 | 81 | -------------------------------------------------------------------------------- /Species.elm: -------------------------------------------------------------------------------- 1 | module Species exposing (Species, name, adjective, glyph, hp, power, resistance, level) 2 | 3 | import ChallengeRating exposing (ChallengeRating(..)) 4 | 5 | -- TYPE 6 | type Species = Bandit | Rat | Snake | Tiger | Dragon | Monkey 7 | 8 | -- ctors 9 | 10 | level : ChallengeRating -> List Species 11 | level rating = 12 | case rating of 13 | Beginner -> 14 | [ Rat, Rat, Rat, Rat, Rat ] 15 | 16 | Easy -> 17 | [ Rat, Monkey, Rat, Snake, Rat ] 18 | 19 | Moderate -> 20 | [ Monkey, Bandit, Snake, Monkey, Monkey ] 21 | 22 | Hard -> 23 | [ Bandit, Tiger, Snake, Bandit, Monkey ] 24 | 25 | Impossible -> 26 | [ Dragon, Tiger, Dragon, Dragon, Tiger ] 27 | 28 | -- helpers 29 | power : Species -> Int 30 | power species = 31 | case species of 32 | Rat -> 2 33 | Monkey -> 4 34 | Snake -> 5 35 | Bandit -> 7 36 | Tiger -> 9 37 | Dragon -> 12 38 | 39 | resistance : Species -> Int 40 | resistance species = 41 | case species of 42 | Rat -> 1 43 | Snake -> 2 44 | Monkey -> 5 45 | Bandit -> 7 46 | Tiger -> 9 47 | Dragon -> 12 48 | 49 | glyph : Species -> Char 50 | glyph species = 51 | case species of 52 | Bandit -> 'b' 53 | Rat -> 'r' 54 | Snake -> 's' 55 | Tiger -> 't' 56 | Dragon -> 'd' 57 | Monkey -> 'm' 58 | 59 | name : Species -> String 60 | name species = 61 | case species of 62 | Bandit -> "bandit" 63 | Rat -> "rat" 64 | Snake -> "snake" 65 | Tiger -> "tiger" 66 | Dragon -> "drake" 67 | Monkey -> "monkey" 68 | 69 | adjective : Species -> String 70 | adjective species = 71 | case species of 72 | Bandit -> "ruthless" 73 | Rat -> "vicious" 74 | Snake -> "wild" 75 | Tiger -> "savage" 76 | Dragon -> "cruel" 77 | Monkey -> "angry" 78 | 79 | hp : Species -> Int 80 | hp species = 81 | case species of 82 | Rat -> 3 83 | Snake -> 7 84 | Monkey -> 10 85 | Bandit -> 14 86 | Tiger -> 25 87 | Dragon -> 50 88 | -------------------------------------------------------------------------------- /Creature.elm: -------------------------------------------------------------------------------- 1 | module Creature exposing (Model, init, step, turn, injure, describe, engage, disengage) 2 | 3 | import Species exposing (Species) 4 | 5 | import Point exposing (Point, slide) 6 | import Direction exposing (Direction(..)) 7 | 8 | import Svg 9 | import Graphics 10 | 11 | import Html 12 | import String 13 | 14 | -- MODEL 15 | type alias Model = 16 | { id : Int 17 | , hp : Int 18 | , maxHp : Int 19 | , defense : Int 20 | , attack : Int 21 | , position : Point 22 | , species : Species 23 | , glyph : Char 24 | , name : String 25 | , subtype : String 26 | , direction : Direction 27 | , engaged : Bool 28 | } 29 | 30 | -- INIT 31 | 32 | init : Species -> Int -> Point -> Model 33 | init species id point = 34 | { id = id 35 | , hp = Species.hp species 36 | , maxHp = Species.hp species 37 | , position = point 38 | , species = species 39 | , glyph = Species.glyph species 40 | , name = Species.name species 41 | , defense = Species.resistance species 42 | , attack = Species.power species 43 | , direction = North 44 | , engaged = False 45 | , subtype = Species.adjective species 46 | } 47 | 48 | step : Model -> Model 49 | step model = 50 | let 51 | position = 52 | model.position 53 | |> slide model.direction 54 | in 55 | { model | position = position } 56 | 57 | turn : Direction -> Model -> Model 58 | turn direction model = 59 | { model | direction = direction } 60 | 61 | injure : Int -> Model -> Model 62 | injure amount model = 63 | let hp' = model.hp - amount in 64 | { model | hp = max 0 hp' } 65 | 66 | describe : Model -> String 67 | describe model = 68 | let 69 | parts = 70 | [ "the", describeHealth model, model.subtype, model.name ] 71 | in 72 | parts 73 | |> String.join " " 74 | 75 | describeHealth : Model -> String 76 | describeHealth model = 77 | if model.hp == model.maxHp then 78 | "healthy" 79 | else 80 | if model.hp > (model.maxHp // 2) then 81 | "hurt" 82 | else 83 | "badly hurt" 84 | 85 | engage : Model -> Model 86 | engage model = 87 | { model | engaged = True } 88 | 89 | disengage : Model -> Model 90 | disengage model = 91 | { model | engaged = False } 92 | -------------------------------------------------------------------------------- /Language.elm: -------------------------------------------------------------------------------- 1 | module Language exposing (Language, Word, generate, decode, wordFor) 2 | 3 | import Util 4 | import Idea exposing (Idea) 5 | 6 | import Random exposing (Generator) 7 | import String 8 | 9 | type Word = Root Idea String 10 | 11 | type alias Language = List Word 12 | 13 | syllables = 14 | [ "ae" 15 | , "al" 16 | , "au" 17 | , "ch" 18 | , "de" 19 | , "ea" 20 | , "el" 21 | , "en" 22 | , "ep" 23 | , "es" 24 | , "eu" 25 | , "jo" 26 | , "li" 27 | , "ll" 28 | , "lm" 29 | , "lo" 30 | , "ma" 31 | , "mne" 32 | , "mu" 33 | , "no" 34 | , "nu" 35 | , "oe" 36 | , "oh" 37 | , "oi" 38 | , "or" 39 | , "ru" 40 | , "ry" 41 | , "sa" 42 | , "sho" 43 | , "thi" 44 | , "us" 45 | ] 46 | 47 | -- init 48 | 49 | init : Idea -> String -> Word 50 | init idea description = 51 | Root idea description 52 | 53 | secret = 54 | Root Idea.holy "???" 55 | 56 | -- translation 57 | decode : Idea -> Language -> Language -> String 58 | decode idea known model = 59 | let 60 | knownIdea = 61 | known 62 | |> List.any (\(Root idea' _) -> idea == idea') 63 | in if knownIdea then 64 | Idea.describe idea 65 | else 66 | model 67 | |> foreignWordFor idea 68 | 69 | foreignWordFor : Idea -> Language -> String 70 | foreignWordFor idea model = 71 | model 72 | |> List.filter (\(Root idea' _) -> idea == idea') 73 | |> List.map (\(Root _ word) -> word) 74 | |> List.head 75 | |> Maybe.withDefault "???" 76 | 77 | wordFor : Idea -> Language -> Word 78 | wordFor idea model = 79 | model 80 | |> List.filter (\(Root idea' _) -> idea == idea') 81 | |> List.head 82 | |> Maybe.withDefault secret 83 | 84 | -- generation 85 | 86 | generateSyllable : Generator String 87 | generateSyllable = 88 | let 89 | pickSyllable = \idx -> 90 | Util.getAt syllables idx 91 | |> Maybe.withDefault "zz" 92 | 93 | randomIdx = 94 | Random.int 0 (List.length syllables-1) 95 | in 96 | Random.map pickSyllable randomIdx 97 | 98 | generateWord : Generator String 99 | generateWord = 100 | let 101 | randomCount = 102 | Random.int 2 3 103 | 104 | syllableList = 105 | Random.list 10 generateSyllable 106 | 107 | constructWord = \ls ct -> 108 | ls 109 | |> List.take ct 110 | |> String.join "" 111 | in 112 | Random.map2 constructWord syllableList randomCount 113 | 114 | generateWords : Generator (List String) 115 | generateWords = 116 | Random.list (List.length Idea.ideas) generateWord 117 | 118 | generate : Generator Language 119 | generate = 120 | let 121 | expression = \words -> 122 | List.map2 init Idea.ideas words 123 | in 124 | Random.map expression generateWords 125 | -------------------------------------------------------------------------------- /Event.elm: -------------------------------------------------------------------------------- 1 | module Event exposing (Event(..), describe, awaken, pickupCoin, attack, killEnemy, defend, enemyEngaged, death, ascend, descend, crystalTaken, hallsEscaped, isEnemyKill, isPlayerDeath, pickupItem) 2 | 3 | import Creature 4 | import Item exposing (Item) 5 | import Language exposing (Language) 6 | 7 | -- TYPES 8 | 9 | type Event 10 | = Awaken 11 | | PickupCoin 12 | | EnemyEngaged Creature.Model 13 | | AttackEnemy Creature.Model Int 14 | | KillEnemy Creature.Model 15 | | DefendEnemy Creature.Model Int 16 | | Death String 17 | | Descend Int 18 | | Ascend Int 19 | | CrystalTaken 20 | | HallsEscaped 21 | | PickupItem Item 22 | 23 | -- ctors 24 | awaken = 25 | Awaken 26 | 27 | pickupCoin = 28 | PickupCoin 29 | 30 | enemyEngaged enemy = 31 | EnemyEngaged enemy 32 | 33 | attack target damage = 34 | AttackEnemy target damage 35 | 36 | killEnemy target = 37 | KillEnemy target 38 | 39 | defend target damage = 40 | DefendEnemy target damage 41 | 42 | death cause = 43 | Death cause 44 | 45 | descend level = 46 | Descend level 47 | 48 | ascend level = 49 | Ascend level 50 | 51 | crystalTaken = 52 | CrystalTaken 53 | 54 | hallsEscaped = 55 | HallsEscaped 56 | 57 | pickupItem item = 58 | PickupItem item 59 | 60 | -- helpers 61 | isEnemyKill event = 62 | case event of 63 | KillEnemy _ -> True 64 | _ -> False 65 | 66 | isPlayerDeath event = 67 | case event of 68 | Death _ -> True 69 | _ -> False 70 | 71 | describe : Language -> Language -> Event -> String 72 | describe vocab lang event = 73 | case event of 74 | Awaken -> 75 | "You awaken in the Timeless Halls of Mandos..." 76 | 77 | PickupCoin -> 78 | "You find a glittering golden coin." 79 | 80 | EnemyEngaged enemy -> 81 | "You see that the " ++ (Creature.describe enemy) ++ " engages you!" 82 | 83 | AttackEnemy enemy dmg -> 84 | "You attack " ++ (Creature.describe enemy) ++ " for " ++ (toString dmg) ++ " damage." 85 | 86 | KillEnemy enemy -> 87 | "You slay " ++ (Creature.describe enemy) ++ "!" 88 | 89 | DefendEnemy enemy dmg -> 90 | "You are attacked by " ++ (Creature.describe enemy) ++ " for " ++ (toString dmg) ++ " damage." 91 | 92 | Death cause -> 93 | "You were slain by " ++ cause 94 | 95 | Ascend lvl -> 96 | "You ascend to level " ++ (toString lvl) 97 | 98 | Descend lvl -> 99 | "You descend to level " ++ (toString lvl) 100 | 101 | CrystalTaken -> 102 | "You take the long-sought Crystal of Time!" 103 | 104 | HallsEscaped -> 105 | "The doors swing open and you emerge into daylight...!" 106 | 107 | PickupItem item -> 108 | "You pick up the " ++ (Item.describe vocab lang item) 109 | -------------------------------------------------------------------------------- /Weapon.elm: -------------------------------------------------------------------------------- 1 | module Weapon exposing (Weapon, damage, describe, averageDamage, threatRange, destroyWalls, dagger, sword, axe, whip, pick, enchant) 2 | 3 | import Util 4 | import Point exposing (Point) 5 | import Direction exposing (Direction) 6 | 7 | import String 8 | 9 | type Weapon = Sword 10 | | Axe 11 | | Dagger 12 | | Whip 13 | | Pick 14 | | Enchanted Int Weapon 15 | 16 | axe : Weapon 17 | axe = 18 | Axe 19 | 20 | dagger : Weapon 21 | dagger = 22 | Dagger 23 | 24 | sword : Weapon 25 | sword = 26 | Sword 27 | 28 | whip : Weapon 29 | whip = 30 | Whip 31 | 32 | pick : Weapon 33 | pick = 34 | Pick 35 | 36 | enchant : Weapon -> Weapon 37 | enchant weapon = 38 | case weapon of 39 | Enchanted n weapon' -> 40 | Enchanted (n+1) weapon' 41 | 42 | _ -> 43 | Enchanted 1 weapon 44 | 45 | destroyWalls : Weapon -> Bool 46 | destroyWalls weapon = 47 | case weapon of 48 | Pick -> True 49 | _ -> False 50 | 51 | threatRange : Point -> Direction -> Weapon -> List Point 52 | threatRange pt dir weapon = 53 | case weapon of 54 | Axe -> 55 | Direction.directions 56 | |> List.map (\dir -> pt |> Point.slide dir) 57 | 58 | Enchanted n weapon' -> 59 | threatRange pt dir weapon' 60 | 61 | Whip -> 62 | [ pt |> Point.slide dir 63 | , pt |> Point.slide dir |> Point.slide dir 64 | , pt |> Point.slide dir |> Point.slide dir |> Point.slide dir 65 | ] 66 | 67 | _ -> 68 | [ pt |> Point.slide dir ] 69 | 70 | averageDamage : Weapon -> Int 71 | averageDamage weapon = 72 | let 73 | dmgRange = 74 | (damageRange weapon) 75 | 76 | midpoint = 77 | (List.length dmgRange) // 2 78 | 79 | avg = 80 | Util.getAt dmgRange midpoint 81 | |> Maybe.withDefault 1 82 | in 83 | avg 84 | 85 | describe : Weapon -> String 86 | describe weapon = 87 | (case weapon of 88 | Sword -> 89 | "sword" 90 | 91 | Axe -> 92 | "axe" 93 | 94 | Dagger -> 95 | "dagger" 96 | 97 | Whip -> 98 | "whip" 99 | 100 | Pick -> 101 | "pick" 102 | 103 | Enchanted n weapon' -> 104 | "+" ++ (toString n) ++ " " ++ (describe weapon')) 105 | 106 | damage : Int -> Int -> Weapon -> Int 107 | damage m n weapon = 108 | let range = (damageRange weapon) in 109 | Util.sample n m 0 range 110 | 111 | damageRange weapon = 112 | case weapon of 113 | Sword -> 114 | [2..8] 115 | 116 | Dagger -> 117 | [1..4] 118 | 119 | Axe -> 120 | [3..5] 121 | 122 | Whip -> 123 | [1..6] 124 | 125 | Pick -> 126 | [0..1] 127 | 128 | Enchanted n weapon' -> 129 | (damageRange weapon') 130 | |> List.map (\x -> x + n) 131 | -------------------------------------------------------------------------------- /Palette.elm: -------------------------------------------------------------------------------- 1 | module Palette exposing (..) 2 | 3 | warning = "red" 4 | alert = "yellow" 5 | info = bright 6 | 7 | active = bright 8 | inactive = "darkgrey" 9 | default = "lightgrey" 10 | 11 | bright = "white" 12 | dim = "lightgray" 13 | dark = "darkgrey" 14 | 15 | primary' shade alpha = rgba (purple' shade alpha) 16 | primaryLighter = rgb (purple 0) 17 | primaryLight = rgb (purple 1) 18 | primary = rgb (purple 2) 19 | primaryDark = rgb (purple 3) 20 | primaryDarker = rgb (purple 4) 21 | 22 | secondary' shade alpha = rgba (yellow' shade alpha) 23 | secondaryLighter = rgb (yellow 0) 24 | secondaryLight = rgb (yellow 1) 25 | secondary = rgb (yellow 2) 26 | secondaryDark = rgb (yellow 3) 27 | secondaryDarker = rgb (yellow 4) 28 | 29 | tertiary' shade alpha = rgba (blue' shade alpha) 30 | tertiaryLighter = rgb (blue 0) 31 | tertiaryLight = rgb (blue 1) 32 | tertiary = rgb (blue 2) 33 | tertiaryDark = rgb (blue 3) 34 | tertiaryDarker = rgb (blue 4) 35 | 36 | accent' shade alpha = rgba (green' shade alpha) 37 | accentLighter = rgb (green 0) 38 | accentLight = rgb (green 1) 39 | accent = rgb (green 2) 40 | accentDark = rgb (green 3) 41 | accentDarker = rgb (green 4) 42 | 43 | rgb : (Int, Int, Int) -> String 44 | rgb (r, g, b) = 45 | "rgb(" 46 | ++ (toString r) 47 | ++ ", " 48 | ++ (toString g) 49 | ++ ", " 50 | ++ (toString b) 51 | ++ ")" 52 | 53 | rgba : (Int, Int, Int, Float) -> String 54 | rgba (r, g, b, a) = 55 | "rgba(" 56 | ++ (toString r) 57 | ++ ", " 58 | ++ (toString g) 59 | ++ ", " 60 | ++ (toString b) 61 | ++ ", " 62 | ++ (toString a) 63 | ++ ")" 64 | 65 | 66 | purple' shade alpha = 67 | let (r,g,b) = purple shade in 68 | (r,g,b,alpha) 69 | 70 | yellow' shade alpha = 71 | let (r,g,b) = yellow shade in 72 | (r,g,b,alpha) 73 | 74 | blue' shade alpha = 75 | let (r,g,b) = blue shade in 76 | (r,g,b,alpha) 77 | 78 | green' shade alpha = 79 | let (r,g,b) = green shade in 80 | (r,g,b,alpha) 81 | 82 | purple : Int -> (Int,Int,Int) 83 | purple shade = 84 | case shade of 85 | 2 -> (154, 25,103) 86 | 0 -> (233,179,212) 87 | 1 -> (190, 77,145) 88 | 3 -> (106, 0, 64) 89 | _ -> ( 35, 0, 21) 90 | 91 | yellow : Int -> (Int, Int, Int) 92 | yellow shade = 93 | case shade of 94 | 2 -> (196,173, 32) 95 | 0 -> (255,247,195) 96 | 1 -> (241,221, 97) 97 | 3 -> (134,116, 0) 98 | _ -> ( 44, 38, 0) 99 | 100 | blue : Int -> (Int, Int, Int) 101 | blue shade = 102 | case shade of 103 | 2 -> ( 65, 33,134) 104 | 0 -> (191,176,223) 105 | 1 -> (104, 77,165) 106 | 3 -> ( 35, 9, 92) 107 | _ -> ( 10, 1, 30) 108 | green : Int -> (Int, Int, Int) 109 | green shade = 110 | case shade of 111 | 2 -> (136,184, 30) 112 | 0 -> (231,249,190) 113 | 1 -> (184,226, 91) 114 | 3 -> ( 87,126, 0) 115 | _ -> ( 28, 41, 0) 116 | 117 | -------------------------------------------------------------------------------- /Path.elm: -------------------------------------------------------------------------------- 1 | module Path exposing (seek, find, findBy) 2 | 3 | import Point exposing (Point, slide) 4 | import Direction exposing (Direction) 5 | 6 | import Util 7 | 8 | type alias PathSegment = (Point, Direction) 9 | 10 | seek : Point -> Point -> (Point -> Bool) -> (List Point) 11 | seek dst src blocked = 12 | find dst src (movesFrom blocked) 13 | |> Maybe.withDefault [] 14 | 15 | movesFrom : (Point -> Bool) -> Point -> List PathSegment 16 | movesFrom blocked point = 17 | Direction.directions 18 | |> List.map (\direction -> (Point.slide direction point, direction)) 19 | |> List.filter ((\p -> not (blocked p)) << fst) 20 | 21 | find : Point -> Point -> (Point -> List PathSegment) -> Maybe (List Point) 22 | find dst src moves = 23 | findBy (\pt -> pt == dst) moves src 24 | 25 | findBy : (Point -> Bool) -> (Point -> List PathSegment) -> Point -> Maybe (List Point) 26 | findBy predicate moves source = 27 | findBy' [] [] source predicate moves 100 28 | 29 | findBy' : List PathSegment -> List PathSegment -> Point -> (Point -> Bool) -> (Point -> List PathSegment) -> Int -> Maybe (List Point) 30 | findBy' visited frontier source predicate moves depth = 31 | if depth < 0 then 32 | Nothing 33 | else 34 | let 35 | maybeGoal = 36 | frontier 37 | |> List.filter (predicate << fst) 38 | |> List.head 39 | in 40 | case maybeGoal of 41 | Just (goal,_) -> 42 | let 43 | path = 44 | (constructPath (visited ++ frontier) source goal) 45 | in 46 | Just (List.reverse path) 47 | 48 | Nothing -> 49 | if List.length frontier == 0 then 50 | let frontier' = moves source in 51 | findBy' visited frontier' source predicate moves (depth-1) 52 | else 53 | let 54 | visitedPositions = 55 | List.map fst newVisited 56 | 57 | newFrontier = 58 | frontier 59 | |> List.concatMap (moves << fst) 60 | |> List.filter (\(pt,_) -> not (List.member pt visitedPositions)) 61 | |> Util.uniqueBy (Point.code << fst) 62 | 63 | newVisited = 64 | (visited ++ frontier) 65 | in 66 | if List.length frontier > 0 then 67 | findBy' newVisited (newFrontier) source predicate moves (depth-1) 68 | else 69 | Nothing 70 | 71 | constructPath : List PathSegment -> Point -> Point -> List Point 72 | constructPath visited source destination = 73 | let 74 | isDestination = \pt -> 75 | pt == destination 76 | 77 | maybeDestination = 78 | visited 79 | |> List.filter (isDestination << fst) 80 | |> List.head 81 | in 82 | if isDestination source then 83 | [] 84 | else 85 | case maybeDestination of 86 | Nothing -> 87 | [] 88 | 89 | Just (point, direction) -> 90 | let 91 | newDest = 92 | point 93 | |> slide (Direction.invert direction) 94 | in 95 | [destination] ++ (constructPath visited source newDest) 96 | -------------------------------------------------------------------------------- /Dungeon.elm: -------------------------------------------------------------------------------- 1 | module Dungeon exposing (Dungeon, generate, prepare, moveCreatures, injureCreature, collectCoin, purge, levelAt, playerSees, removeItem, playerDestroysWall, evolve, viewFrontier, apply) 2 | 3 | import Warrior 4 | import Creature 5 | import Point exposing (Point) 6 | import Room exposing (Room) 7 | import Graph 8 | import Direction exposing (Direction(..)) 9 | import Level exposing (Level) 10 | import Event exposing (Event) 11 | import Util 12 | import Item exposing (Item) 13 | import Configuration 14 | 15 | import Random 16 | import Set exposing (Set) 17 | 18 | -- TYPE 19 | type alias Dungeon = List Level 20 | 21 | -- GENERATOR 22 | generate : Int -> Random.Generator Dungeon 23 | generate depth = 24 | Random.list (depth) (Random.map Level.fromRooms (Room.generate Configuration.candidateRooms)) 25 | 26 | prepare : Int -> Dungeon -> Dungeon 27 | prepare depth model = 28 | model 29 | |> List.indexedMap Level.finalize 30 | 31 | -- HELPERS 32 | levelAt : Int -> Dungeon -> Level 33 | levelAt depth model = 34 | Util.getAt model depth 35 | |> Maybe.withDefault Level.init 36 | 37 | apply : (Level -> Level) -> Int -> Dungeon -> Dungeon 38 | apply f depth model = 39 | let 40 | level = 41 | model |> apply' f depth 42 | 43 | model' = 44 | model |> List.indexedMap (\n level' -> 45 | if n == depth then level else level') 46 | in 47 | model' 48 | 49 | apply' : (Level -> a) -> Int -> Dungeon -> a 50 | apply' f depth model = 51 | f (levelAt depth model) 52 | 53 | collectCoin : Point -> Int -> Dungeon -> Dungeon 54 | collectCoin pt depth model = 55 | model 56 | |> apply (Level.collectCoin pt) depth 57 | 58 | removeItem : Item -> Int -> Dungeon -> Dungeon 59 | removeItem item depth model = 60 | model 61 | |> apply (Level.removeItem item) depth 62 | 63 | moveCreatures : Warrior.Model -> Int -> Dungeon -> (Dungeon, List Event, Warrior.Model) 64 | moveCreatures player depth model = 65 | let 66 | (level, events, player') = 67 | model |> apply' (Level.moveCreatures player) depth 68 | 69 | model' = 70 | model |> List.indexedMap (\n level' -> 71 | if n == depth then level else level') 72 | in 73 | (model', events, player') 74 | 75 | injureCreature : Creature.Model -> Int -> Int -> Dungeon -> Dungeon 76 | injureCreature creature amount depth model = 77 | model |> apply (Level.injureCreature creature amount) depth 78 | 79 | purge : Int -> Dungeon -> (Dungeon, List Event) 80 | purge depth model = 81 | let 82 | (level, events) = 83 | model |> apply' Level.purge depth 84 | model' = 85 | model |> List.indexedMap (\n level' -> 86 | if n == depth then level else level') 87 | in 88 | (model', events) 89 | 90 | playerSees : Set Point -> Int -> Dungeon -> Dungeon 91 | playerSees pts depth model = 92 | model |> apply (Level.playerSees pts) depth 93 | 94 | playerDestroysWall : Point -> Int -> Dungeon -> Dungeon 95 | playerDestroysWall pt depth model = 96 | model |> apply (Level.extrude pt) depth 97 | 98 | evolve : Dungeon -> Dungeon 99 | evolve model = 100 | model 101 | |> List.map (\level -> level |> Level.evolveGrass 1) 102 | 103 | viewFrontier : Int -> Dungeon -> Set Point 104 | viewFrontier depth model = 105 | model |> apply' (Level.viewFrontier) depth 106 | -------------------------------------------------------------------------------- /Point.elm: -------------------------------------------------------------------------------- 1 | module Point exposing (Point, slide, describe, distance, random, randomWithOffset, code, perimeter, grid, isAdjacent, towards, towards', adjacent) 2 | 3 | import Direction exposing (Direction(..), directions) 4 | import Configuration 5 | 6 | import Set exposing (Set) 7 | import Random 8 | 9 | type alias Point = ( Int, Int ) 10 | 11 | adjacent : Point -> List Point 12 | adjacent pt = 13 | Direction.directions 14 | |> List.map (\dir -> pt |> slide dir) 15 | --|> Set.fromList 16 | 17 | isAdjacent a b = 18 | adjacent a 19 | |> List.member b 20 | 21 | slide : Direction -> Point -> Point 22 | slide direction (x,y) = 23 | case direction of 24 | North -> 25 | (x, y - 1) 26 | 27 | South -> 28 | (x, y + 1) 29 | 30 | West -> 31 | (x - 1, y) 32 | 33 | East -> 34 | (x + 1, y) 35 | 36 | Northeast -> 37 | (x,y) 38 | |> slide North 39 | |> slide East 40 | 41 | Northwest -> 42 | (x,y) 43 | |> slide North 44 | |> slide West 45 | 46 | Southeast -> 47 | (x,y) 48 | |> slide South 49 | |> slide East 50 | 51 | Southwest -> 52 | (x,y) 53 | |> slide South 54 | |> slide West 55 | 56 | describe : Point -> String 57 | describe (x,y) = 58 | "(" ++ (toString x) ++ ", " ++ (toString y) ++ ")" 59 | 60 | distance : Point -> Point -> Float 61 | distance (ax,ay) (bx,by) = 62 | let 63 | dx = 64 | toFloat (ax - bx) 65 | 66 | dy = 67 | toFloat (ay - by) 68 | in 69 | sqrt( (dx*dx) + (dy*dy) ) 70 | 71 | random : Int -> Int -> Random.Generator Point 72 | random width height = 73 | Random.map2 (\x y -> (x,y)) (Random.int 0 width) (Random.int 0 height) 74 | 75 | 76 | randomWithOffset : Point -> Int -> Int -> Random.Generator Point 77 | randomWithOffset (x,y) width height = 78 | Random.map2 (\x' y' -> (x+x',y+y')) (Random.int 0 width) (Random.int 0 height) 79 | 80 | code : Point -> Int 81 | code (x,y) = 82 | (x * 10000) + y 83 | 84 | perimeter : Point -> Int -> Int -> Set Point 85 | perimeter (x,y) width height = 86 | let ls = 87 | List.map (\x' -> (x+x',y)) [0..width] ++ 88 | List.map (\x' -> (x+x',y+height)) [0..width] ++ 89 | List.map (\y' -> (x,y+y')) [0..height] ++ 90 | List.map (\y' -> (x+width,y+y')) [0..height] 91 | in 92 | Set.fromList ls 93 | 94 | grid : Point -> Int -> Int -> Set Point 95 | grid (x,y) width height = 96 | List.concatMap (\y' -> 97 | List.map (\x' -> (x+x',y+y')) [0..(width)] 98 | ) [0..(height)] 99 | |> Set.fromList 100 | 101 | towards : Point -> Point -> Direction 102 | towards (ax,ay) (bx,by) = 103 | if (ax > bx) && (ay > by) then 104 | Southeast 105 | else 106 | if (ax < bx) && (ay > by) then 107 | Southwest 108 | else 109 | if (ax > bx) && (ay < by) then 110 | Northeast 111 | else 112 | if (ax < bx) && (ay < by) then 113 | Northwest 114 | else 115 | towards' (ax,ay) (bx,by) 116 | 117 | towards' : Point -> Point -> Direction 118 | towards' (ax,ay) (bx,by) = 119 | let 120 | dx = 121 | abs (ax - bx) 122 | dy = 123 | abs (ay - by) 124 | 125 | in 126 | if dx > dy then 127 | if (ax > bx) then 128 | East 129 | else 130 | West 131 | else 132 | if (ay > by) then 133 | South 134 | else 135 | North 136 | 137 | 138 | -------------------------------------------------------------------------------- /Util.elm: -------------------------------------------------------------------------------- 1 | module Util exposing (minBy, uniqueBy, getAt, dropWhile, everyNth, mapEveryNth, sample, zip, filterChamp, toAlpha, fromAlpha) 2 | 3 | import Point exposing (Point) 4 | import Direction exposing (Direction(..)) 5 | import Set exposing (Set) 6 | ---import Mouse 7 | 8 | import String 9 | 10 | 11 | alphabet = 12 | ['b','c','e','f','g','m','n','o','p','q','r','s','t','u','v','x','y','z','-'] 13 | 14 | toAlpha : Int -> String 15 | toAlpha idx = 16 | let alpha = (getAt alphabet idx |> Maybe.withDefault '-') in 17 | String.fromChar alpha 18 | 19 | fromAlpha : Char -> Int 20 | fromAlpha ch = 21 | elemIndex ch alphabet 22 | |> Maybe.withDefault -1 23 | 24 | -- deterministically 'sample' a list based on two variables 25 | sample : Int -> Int -> a -> List a -> a 26 | sample m n zero ls = 27 | getAt ls ((m ^ 31 + n) % (max 1 (List.length ls - 1))) 28 | |> Maybe.withDefault zero 29 | 30 | filterChamp : List a -> List a 31 | filterChamp ls = 32 | let champ' = champ 100 in 33 | ls 34 | |> List.indexedMap (\n a -> (n,a)) 35 | |> List.filter (\(n,_) -> 36 | getAt champ' n 37 | |> Maybe.withDefault False) 38 | |> List.map snd 39 | 40 | -- binary champernowne 41 | champernowne : Int -> Bool 42 | champernowne n = 43 | getAt (champ n) n 44 | |> Maybe.withDefault False 45 | 46 | champ : Int -> List Bool 47 | champ n = 48 | List.concatMap toBools [1..n] 49 | 50 | toBools : Int -> List Bool 51 | toBools n = 52 | let 53 | lsb = 54 | if n % 2 == 0 then 55 | [False] 56 | else 57 | [True] 58 | in 59 | if n < 2 then 60 | lsb 61 | else 62 | (toBools (n//2)) ++ lsb 63 | 64 | -- 65 | --pick 66 | 67 | everyNth n ls = 68 | case (ls |> List.drop (n-1)) of 69 | [] -> 70 | [] 71 | (head :: rest) -> 72 | head :: (everyNth n rest) 73 | 74 | mapEveryNth n f ls = 75 | let ls' = List.take (n-1) ls in 76 | case (List.drop (n-1) ls) of 77 | [] -> 78 | ls' 79 | (head :: rest) -> 80 | ls' ++ ((f head) :: (mapEveryNth n f rest)) 81 | 82 | 83 | zip : List a -> List b -> List (a,b) 84 | zip xs ys = 85 | case (xs, ys) of 86 | ( x :: xs', y :: ys' ) -> 87 | (x,y) :: zip xs' ys' 88 | 89 | (_, _) -> 90 | [] 91 | 92 | -- helpers from list extras 93 | minBy : (a -> comparable) -> List a -> Maybe a 94 | minBy f ls = 95 | let minBy x (y, fy) = let fx = f x in if fx < fy then (x, fx) else (y, fy) 96 | in case ls of 97 | [l'] -> Just l' 98 | l'::ls' -> Just <| fst <| List.foldl minBy (l', f l') ls' 99 | _ -> Nothing 100 | 101 | uniqueBy f list = 102 | uniqueHelp f Set.empty list 103 | 104 | uniqueHelp : (a -> comparable) -> Set comparable -> List a -> List a 105 | uniqueHelp f existing remaining = 106 | case remaining of 107 | [] -> 108 | [] 109 | 110 | first :: rest -> 111 | let computedFirst = f first in 112 | if Set.member computedFirst existing then 113 | uniqueHelp f existing rest 114 | else 115 | first :: uniqueHelp f (Set.insert computedFirst existing) rest 116 | 117 | getAt : List a -> Int -> Maybe a 118 | getAt xs idx = List.head <| List.drop idx xs 119 | 120 | dropWhile : (a -> Bool) -> List a -> List a 121 | dropWhile predicate list = 122 | case list of 123 | [] -> [] 124 | x::xs -> if (predicate x) then dropWhile predicate xs 125 | else list 126 | 127 | elemIndex : a -> List a -> Maybe Int 128 | elemIndex x = findIndex ((==)x) 129 | 130 | findIndex : (a -> Bool) -> List a -> Maybe Int 131 | findIndex p = List.head << findIndices p 132 | 133 | findIndices : (a -> Bool) -> List a -> List Int 134 | findIndices p = List.map fst << List.filter (\(i,x) -> p x) << List.indexedMap (,) 135 | -------------------------------------------------------------------------------- /Graph.elm: -------------------------------------------------------------------------------- 1 | module Graph exposing (Graph, map, fold, minimumBy, match, node, edge, nodeWithEdges, tree, listNodes) 2 | import Util 3 | 4 | type Graph a = Node a (List (Graph a)) 5 | 6 | node x = 7 | Node x [] 8 | 9 | nodeWithEdges x edges = 10 | Node x edges 11 | 12 | -- map values 13 | map : (a -> b) -> Graph a -> Graph b 14 | map f (Node n ns) = 15 | Node (f n) (List.map (map f) ns) 16 | 17 | -- map nodes themselves (i.e., wrapped, with structure) 18 | mapNodes : (Graph a -> Graph a) -> Graph a -> Graph a 19 | mapNodes f (Node n ns) = 20 | f (Node n (List.map (mapNodes f) ns)) 21 | 22 | listNodes : Graph a -> List a 23 | listNodes (Node n ns) = 24 | n :: (List.concatMap (listNodes) ns) 25 | 26 | -- fold over edges 27 | fold : ((a,a) -> b -> b) -> b -> Graph a -> b 28 | fold f initial graph = 29 | List.foldr f initial (edges graph) 30 | 31 | edges : Graph a -> List (a,a) 32 | edges (Node n ns) = 33 | let 34 | edges' = 35 | List.map (\n' -> (n, nodeValue n')) ns 36 | in 37 | edges' ++ (List.concatMap edges ns) 38 | 39 | edge : a -> a -> Graph a -> Graph a 40 | edge n n' graph = 41 | mapNodes (joinMatching n n') graph 42 | 43 | joinMatching : a -> a -> Graph a -> Graph a 44 | joinMatching n node' trialNode = 45 | let (Node n' _) = trialNode in 46 | if n' == n then 47 | connect' trialNode (node node') 48 | else 49 | trialNode 50 | 51 | connect' : Graph a -> Graph a -> Graph a 52 | connect' (Node n ns) n' = 53 | Node n (n' :: ns) 54 | 55 | nodeValue : Graph a -> a 56 | nodeValue (Node n _) = n 57 | 58 | 59 | 60 | minimumBy : (a -> comparable) -> Graph a -> Graph a 61 | minimumBy f graph = 62 | minimumWhere f (\_ -> True) graph 63 | |> Maybe.withDefault (graph) 64 | 65 | -- minimum by a comparator, filtered by a bool 66 | minimumWhere : (a -> comparable) -> (a -> Bool) -> Graph a -> Maybe (Graph a) 67 | minimumWhere f pred graph = 68 | let 69 | (Node n edges) = 70 | graph 71 | 72 | minEdges = 73 | edges 74 | |> List.filterMap (minimumWhere f pred) 75 | 76 | minRest = 77 | minEdges 78 | |> Util.minBy (\n' -> f (nodeValue n')) 79 | in 80 | case minRest of 81 | Just minRestNode -> 82 | let restMinDist = f (nodeValue minRestNode) in 83 | if (f n) < restMinDist && pred n then 84 | Just graph 85 | else 86 | minRest 87 | 88 | Nothing -> 89 | if pred n then 90 | Just graph 91 | else 92 | Nothing 93 | 94 | match : Graph a -> Graph a -> Bool 95 | match n graph = 96 | let 97 | (Node _ rest) = 98 | graph 99 | in 100 | if n == graph then 101 | True 102 | else 103 | if List.length rest == 0 then 104 | False 105 | else 106 | List.any (match n) rest 107 | 108 | span : (a -> a -> comparable) -> List a -> Maybe (Graph a) 109 | span f ls = tree f (\_ _ -> True) ls 110 | 111 | tree : (a -> a -> comparable) -> (a -> a -> Bool) -> List a -> Maybe (Graph a) 112 | tree f predicate ls = 113 | case (List.head ls) of 114 | Nothing -> 115 | Nothing 116 | 117 | Just elem -> 118 | let 119 | firstNode = 120 | node elem 121 | in 122 | case (List.tail ls) of 123 | Nothing -> 124 | Just firstNode 125 | 126 | Just rest -> 127 | Just (tree' f predicate firstNode rest) 128 | 129 | tree' : (a -> a -> comparable) -> (a -> a -> Bool) -> Graph a -> List a -> Graph a 130 | tree' f pred graph ls = 131 | let 132 | weight = \x -> -- least f to a node in the graph 133 | graph 134 | |> minimumBy (f x) 135 | |> nodeValue 136 | |> f x 137 | 138 | rest = 139 | ls |> List.sortBy weight 140 | 141 | in 142 | case (List.head rest) of 143 | Nothing -> 144 | graph 145 | 146 | Just elem -> 147 | let 148 | closestNode = 149 | graph 150 | |> minimumWhere (f elem) (pred elem) 151 | 152 | graph' = 153 | case closestNode of 154 | Just closest -> 155 | graph |> edge (nodeValue closest) (elem) 156 | 157 | Nothing -> 158 | graph 159 | in 160 | case (List.tail rest) of 161 | Nothing -> 162 | graph' 163 | 164 | Just rest' -> 165 | rest' |> tree' f pred graph' 166 | -------------------------------------------------------------------------------- /Item.elm: -------------------------------------------------------------------------------- 1 | module Item exposing (Item, init, glyph, name, describe, ItemKind(..), weapon, armor, ring, helm, bottle, scroll, javelin, crystal, enchant, simple, canApply, thrownDamage) 2 | 3 | import Point exposing (Point) 4 | import Weapon exposing (Weapon) 5 | import Armor exposing (Armor) 6 | import Ring exposing (Ring) 7 | import Helm exposing (Helm) 8 | import Liquid exposing (Liquid) 9 | import Spell exposing (Spell) 10 | import Language exposing (Language) 11 | import Idea 12 | 13 | type QuestItemKind = Crystal 14 | 15 | type AmmoKind = Spear 16 | | Javelin 17 | 18 | type ItemKind = Arm Weapon 19 | | Throwing AmmoKind 20 | | Shield Armor 21 | | Bottle Liquid 22 | | Scroll Spell 23 | | Jewelry Ring 24 | | Headgear Helm 25 | | QuestItem QuestItemKind 26 | 27 | weapon weapon' = 28 | Arm weapon' 29 | 30 | armor armor' = 31 | Shield armor' 32 | 33 | bottle liquid = 34 | Bottle liquid 35 | 36 | scroll spell = 37 | Scroll spell 38 | 39 | ring ring' = 40 | Jewelry ring' 41 | 42 | helm helm' = 43 | Headgear helm' 44 | 45 | javelin = 46 | Throwing Javelin 47 | 48 | crystal = 49 | QuestItem Crystal 50 | 51 | type alias Item = { position : Point 52 | , kind : ItemKind 53 | , id : Int 54 | } 55 | 56 | init pt kind id = 57 | { position = pt 58 | , kind = kind 59 | , id = id 60 | } 61 | 62 | simple kind = 63 | { position = (0,0), kind = kind, id = -101 } 64 | 65 | glyph : Item -> String 66 | glyph {kind} = 67 | case kind of 68 | Arm _ -> 69 | ")" 70 | 71 | Shield _ -> 72 | "[" 73 | 74 | Headgear _ -> 75 | "^" 76 | 77 | Jewelry _ -> 78 | "&" 79 | 80 | Bottle _ -> 81 | "?" 82 | 83 | Scroll _ -> 84 | "~" 85 | 86 | QuestItem _ -> 87 | "∆" 88 | 89 | Throwing _ -> 90 | "|" 91 | 92 | name : Item -> String 93 | name item = 94 | case item.kind of 95 | Arm weapon' -> 96 | Weapon.describe weapon' 97 | 98 | Shield armor' -> 99 | Armor.describe armor' 100 | 101 | Jewelry ring -> 102 | "ring of " 103 | ++ (Idea.describe (Spell.idea (Ring.spell ring))) 104 | 105 | Headgear helm -> 106 | Helm.describe helm 107 | 108 | Bottle liquid -> 109 | "bottle of " 110 | ++ (Idea.describe (Liquid.idea liquid)) 111 | 112 | Scroll spell -> 113 | "scroll of " 114 | ++ (Idea.describe (Spell.idea spell)) 115 | 116 | Throwing thrown -> 117 | case thrown of 118 | Spear -> "spear" 119 | Javelin -> "javelin" 120 | 121 | QuestItem kind -> 122 | case kind of 123 | Crystal -> 124 | "crystal of time" 125 | 126 | describe : Language -> Language -> Item -> String 127 | describe vocab language {kind} = 128 | case kind of 129 | Arm weapon' -> 130 | Weapon.describe weapon' 131 | 132 | Shield armor' -> 133 | Armor.describe armor' 134 | 135 | Jewelry ring -> 136 | Ring.describe vocab language ring 137 | 138 | Headgear helm -> 139 | Helm.describe helm 140 | 141 | Bottle liquid -> 142 | "bottle of " 143 | ++ (Language.decode (Liquid.idea liquid) vocab language) 144 | 145 | Scroll spell -> 146 | "scroll of " 147 | ++ (Language.decode (Spell.idea spell) vocab language) 148 | 149 | Throwing thrown -> 150 | case thrown of 151 | Spear -> "spear" 152 | Javelin -> "javelin" 153 | 154 | QuestItem kind -> 155 | case kind of 156 | Crystal -> 157 | "crystal of time" 158 | 159 | enchant : Item -> Item 160 | enchant item = 161 | case item.kind of 162 | Arm weapon -> 163 | { item | kind = Arm (Weapon.enchant weapon) } 164 | 165 | Shield armor -> 166 | { item | kind = Shield (Armor.enchant armor) } 167 | 168 | Jewelry ring -> 169 | { item | kind = Jewelry (Ring.enchant ring) } 170 | 171 | Headgear helm -> 172 | { item | kind = Headgear (Helm.enchant helm) } 173 | 174 | Throwing thrown -> 175 | item 176 | 177 | Bottle _ -> 178 | item 179 | 180 | Scroll _ -> 181 | item 182 | 183 | QuestItem _ -> 184 | item 185 | 186 | canApply item' item = 187 | case item'.kind of 188 | Scroll spell -> 189 | if spell == Spell.infuse then 190 | case item.kind of 191 | Arm _ -> 192 | True 193 | 194 | Shield _ -> 195 | True 196 | 197 | Jewelry _ -> 198 | True 199 | 200 | Headgear _ -> 201 | True 202 | 203 | _ -> 204 | False 205 | else 206 | False 207 | 208 | _ -> 209 | False 210 | 211 | 212 | thrownDamage item = 213 | case item.kind of 214 | Throwing ammo -> 215 | 200 216 | 217 | _ -> 218 | 1 219 | 220 | -------------------------------------------------------------------------------- /Action.elm: -------------------------------------------------------------------------------- 1 | module Action exposing (Action(..), describe, question, defaultForItem, canPerform, drop, enchant, use, default, hurl, describeWithDefault) 2 | 3 | import Language exposing (Language) 4 | import Item exposing (Item, ItemKind(..)) 5 | 6 | type Action = Drop 7 | | Throw 8 | | Hurl Item 9 | | Identify 10 | | Wield 11 | | Wear 12 | | Drink 13 | | Look 14 | | Read 15 | | Enchant 16 | | Use Item Action 17 | | Default 18 | | Sheathe 19 | | TakeOff 20 | 21 | drop = 22 | Drop 23 | 24 | throw = 25 | Throw 26 | 27 | hurl it = 28 | Hurl it 29 | 30 | default = 31 | Default 32 | 33 | enchant = 34 | Enchant 35 | 36 | use item action = 37 | Use item action 38 | 39 | defaultForItem : Bool -> Item -> Action 40 | defaultForItem equipped {kind} = 41 | case kind of 42 | Arm _ -> 43 | if equipped then Sheathe else Wield 44 | 45 | Shield _ -> 46 | if equipped then TakeOff else Wear 47 | 48 | Jewelry _ -> 49 | if equipped then TakeOff else Wear 50 | 51 | Headgear _ -> 52 | if equipped then TakeOff else Wear 53 | 54 | Bottle _ -> 55 | Drink 56 | 57 | Scroll _ -> 58 | Read 59 | 60 | QuestItem _ -> 61 | Look 62 | 63 | Throwing _ -> 64 | Throw 65 | 66 | canPerform : Bool -> Item -> Action -> Bool 67 | canPerform equipped item action = 68 | let {kind} = item in 69 | case action of 70 | Default -> 71 | -- todo check if equipped? (e.g., cursed items?) 72 | canPerform equipped item (defaultForItem False item) 73 | 74 | Wield -> 75 | case kind of 76 | Arm _ -> True 77 | _ -> False 78 | 79 | Wear -> 80 | case kind of 81 | Shield _ -> True 82 | Jewelry _ -> True 83 | Headgear _ -> True 84 | _ -> False 85 | 86 | Read -> 87 | case kind of 88 | Scroll _ -> True 89 | _ -> False 90 | 91 | Drink -> 92 | case kind of 93 | Bottle _ -> True 94 | _ -> False 95 | 96 | Drop -> 97 | case kind of 98 | QuestItem _ -> False 99 | _ -> not equipped 100 | 101 | Enchant -> 102 | case kind of 103 | Arm _ -> True 104 | Shield _ -> True 105 | Jewelry _ -> True 106 | Headgear _ -> True 107 | _ -> False 108 | 109 | Use item' action' -> 110 | canPerform equipped item action' 111 | 112 | Throw -> 113 | case kind of 114 | Throwing _ -> 115 | True 116 | 117 | _ -> 118 | False 119 | 120 | _ -> False 121 | 122 | describe : Action -> String 123 | describe action = 124 | case action of 125 | Drop -> 126 | "Remove" 127 | 128 | Throw -> 129 | "Hurl" 130 | 131 | Identify -> 132 | "Identify" 133 | 134 | Wield -> 135 | "Equip" 136 | 137 | Wear -> 138 | "Equip" 139 | 140 | Drink -> 141 | "Drink" 142 | 143 | Look -> 144 | "Inspect" 145 | 146 | Read -> 147 | "Read" 148 | 149 | Enchant -> 150 | "Enchant" 151 | 152 | Sheathe -> 153 | "Sheathe" 154 | 155 | TakeOff -> 156 | "Take off" 157 | 158 | Hurl item -> 159 | "Throw " ++ (Item.name item) ++ "..." 160 | 161 | Use item action' -> 162 | describe action' 163 | --"Use " ++ (Item.name item) ++ " to " ++ describe action' ++ "..." 164 | 165 | Default -> 166 | "[Default]" 167 | 168 | describeWithDefault : Item -> Bool -> Action -> String 169 | describeWithDefault item equipped action = 170 | case action of 171 | Default -> 172 | describe (defaultForItem equipped item) 173 | _ -> describe action 174 | 175 | question : Language -> Language -> Action -> String 176 | question vocab language action = 177 | case action of 178 | Drop -> 179 | "What would you like to get rid of?" 180 | 181 | Throw -> 182 | "What would you like to throw?" 183 | 184 | Identify -> 185 | "What mysterious object would you like to identify?" 186 | 187 | Wield -> 188 | "Which weapon would you like to wield?" 189 | 190 | Wear -> 191 | "What would you like to wear?" 192 | 193 | Drink -> 194 | "What would you like to drink?" 195 | 196 | Look -> 197 | "Where would you like to look?" 198 | 199 | Read -> 200 | "What would you like to read?" 201 | 202 | Enchant -> 203 | "What would you like to enchant?" 204 | 205 | Sheathe -> 206 | "What would you like to sheathe?" 207 | 208 | TakeOff -> 209 | "What would you like to take off?" 210 | 211 | Use item action' -> 212 | "What would you like to " ++ (describe action') ++ " with " ++ (Item.describe vocab language item) ++ "?" 213 | 214 | Hurl item -> 215 | "What would you like to throw the " ++ (Item.describe vocab language item) ++ " at?" 216 | 217 | Default -> 218 | "What would you like to do?" 219 | -------------------------------------------------------------------------------- /Entity.elm: -------------------------------------------------------------------------------- 1 | module Entity exposing (Entity(..), view, describe, position, wall, floor, coin, player, monster, door, upstairs, downstairs, memory, entrance, crystal, imaginary, isCreature, item, grass) 2 | 3 | import Point exposing (Point) 4 | import Item 5 | import Creature 6 | import Warrior 7 | import String 8 | import Graphics 9 | import Palette 10 | import Language exposing (Language) 11 | 12 | import Svg 13 | 14 | -- types 15 | type Entity = Monster Creature.Model 16 | | Player Warrior.Model 17 | | Wall Point 18 | | Coin Point 19 | | Floor Point 20 | | Door Point 21 | | StairsUp Point 22 | | StairsDown Point 23 | | Memory Entity 24 | | Entrance Bool Point 25 | | Imaginary Entity 26 | | Item Item.Item 27 | | Grass Point 28 | 29 | -- constructors 30 | wall point = 31 | Wall point 32 | 33 | coin point = 34 | Coin point 35 | 36 | floor point = 37 | Floor point 38 | 39 | door point = 40 | Door point 41 | 42 | player warrior = 43 | Player warrior 44 | 45 | monster creature = 46 | Monster creature 47 | 48 | upstairs point = 49 | StairsUp point 50 | 51 | downstairs point = 52 | StairsDown point 53 | 54 | memory entity = 55 | Memory entity 56 | 57 | crystal pt = 58 | Item (Item.init pt Item.crystal -1) 59 | 60 | entrance open pt = 61 | Entrance open pt 62 | 63 | imaginary entity = 64 | Imaginary entity 65 | 66 | item item' = 67 | Item item' 68 | 69 | grass pt = 70 | Grass pt 71 | 72 | isCreature entity = 73 | case entity of 74 | Monster _ -> 75 | True 76 | 77 | _ -> 78 | False 79 | 80 | -- helpers 81 | 82 | describe : Language -> Language -> Entity -> String 83 | describe vocab language entity = 84 | case entity of 85 | Monster creature -> 86 | Creature.describe creature 87 | 88 | Player player -> 89 | "a nameless warrior" 90 | 91 | Wall _ -> 92 | "a sturdy wall" 93 | 94 | Coin _ -> 95 | "a golden coin" 96 | 97 | Floor _ -> 98 | "a cobblestone floor" 99 | 100 | Door _ -> 101 | "a creaky door" 102 | 103 | Grass _ -> 104 | "a patch of grass" 105 | 106 | StairsUp _ -> 107 | "an upward-curving staircase" 108 | 109 | StairsDown _ -> 110 | "a downward-curving staircase" 111 | 112 | Memory entity -> 113 | "You saw " ++ (describe vocab language entity) ++ " here" 114 | 115 | Imaginary entity -> 116 | "You imagine there is " ++ (describe vocab language entity) ++ " here" 117 | 118 | Entrance open _ -> 119 | if open then 120 | "an open heavy metal gateway and daylight beyond" 121 | else 122 | "a closed heavy metal gateway" 123 | 124 | Item item -> 125 | Item.describe vocab language item 126 | 127 | -- view 128 | view : Entity -> Svg.Svg a 129 | view entity = 130 | Graphics.render (glyph entity) (position entity) (color entity) 131 | 132 | color : Entity -> String 133 | color entity = 134 | case entity of 135 | Player _ -> 136 | Palette.bright 137 | 138 | Monster _ -> 139 | Palette.dim 140 | 141 | Item _ -> 142 | Palette.secondaryLight 143 | 144 | Coin _ -> 145 | Palette.alert 146 | 147 | Wall _ -> 148 | Palette.dim 149 | 150 | Floor _ -> 151 | Palette.primary 152 | 153 | Entrance open _ -> 154 | Palette.bright 155 | 156 | Door _ -> 157 | Palette.tertiaryLight 158 | 159 | StairsUp _ -> 160 | Palette.bright 161 | 162 | StairsDown _ -> 163 | Palette.bright 164 | 165 | Grass _ -> 166 | Palette.accent 167 | 168 | Memory _ -> 169 | Palette.primary' 2 0.5 170 | 171 | Imaginary _ -> 172 | Palette.secondary' 2 0.5 173 | 174 | position : Entity -> Point.Point 175 | position entity = 176 | case entity of 177 | Monster creature -> 178 | creature.position 179 | 180 | Player player -> 181 | player.position 182 | 183 | Door point -> 184 | point 185 | 186 | Wall point -> 187 | point 188 | 189 | Coin point -> 190 | point 191 | 192 | Floor point -> 193 | point 194 | 195 | StairsUp point -> 196 | point 197 | 198 | StairsDown point -> 199 | point 200 | 201 | Entrance _ pt -> 202 | pt 203 | 204 | Memory entity -> 205 | position entity 206 | 207 | Imaginary entity -> 208 | position entity 209 | 210 | Item item -> 211 | item.position 212 | 213 | Grass pt -> 214 | pt 215 | 216 | glyph : Entity -> String 217 | glyph entity = 218 | case entity of 219 | Monster creature -> 220 | String.fromChar creature.glyph 221 | 222 | Player _ -> 223 | "@" 224 | 225 | Wall _ -> 226 | "#" 227 | 228 | Coin _ -> 229 | "*" 230 | 231 | Floor _ -> 232 | "." 233 | 234 | Door _ -> 235 | "+" 236 | 237 | StairsUp _ -> 238 | ">" 239 | 240 | StairsDown _ -> 241 | "<" 242 | 243 | Memory e -> 244 | glyph e 245 | 246 | Imaginary e -> 247 | glyph e 248 | 249 | Entrance _ _ -> 250 | "=" 251 | 252 | Grass _ -> 253 | "\"" 254 | 255 | Item item -> 256 | Item.glyph item 257 | -------------------------------------------------------------------------------- /Inventory.elm: -------------------------------------------------------------------------------- 1 | module Inventory exposing (view, itemAtIndex, size) 2 | 3 | import Util 4 | import Point exposing (Point) 5 | import Warrior exposing (Model) 6 | import Weapon exposing (Weapon) 7 | import Armor exposing (Armor) 8 | import Ring exposing (Ring) 9 | import Helm exposing (Helm) 10 | import Action exposing (Action) 11 | import Item exposing (Item) 12 | import Graphics 13 | import Palette 14 | import Language exposing (Language) 15 | 16 | import Dict exposing (Dict) 17 | import Svg 18 | 19 | type Equipment = EquippedWeapon Weapon 20 | | EquippedArmor Armor 21 | | EquippedRing Ring 22 | | EquippedHelm Helm 23 | 24 | -- HELPERS 25 | size : Model -> Int 26 | size model = 27 | model |> organize |> Dict.size 28 | 29 | organize : Model -> Dict String (Int, Item) 30 | organize model = 31 | let 32 | countItems = \it dict -> 33 | dict 34 | |> Dict.update (Item.name it) (\entry -> 35 | case entry of 36 | Nothing -> 37 | Just (1,it) 38 | 39 | Just (ct',it') -> 40 | Just (ct' + 1, it') 41 | ) 42 | in 43 | model.inventory 44 | |> List.foldr countItems Dict.empty 45 | 46 | organizedItemAt : Int -> Model -> Maybe Item 47 | organizedItemAt idx model = 48 | let 49 | inv = 50 | model |> organize |> Dict.values 51 | 52 | maybeTuple = 53 | Util.getAt inv idx 54 | in 55 | case maybeTuple of 56 | Nothing -> 57 | Nothing 58 | 59 | Just (_,item) -> 60 | Just item 61 | 62 | asItem : Equipment -> Item 63 | asItem equipment = 64 | let toItem = case equipment of 65 | EquippedArmor armor -> 66 | Item.armor armor 67 | 68 | EquippedWeapon weapon -> 69 | Item.weapon weapon 70 | 71 | EquippedRing ring -> 72 | Item.ring ring 73 | 74 | EquippedHelm helm -> 75 | Item.helm helm 76 | 77 | in Item.simple toItem 78 | 79 | equippedItems model = 80 | let 81 | weapon = case model.weapon of 82 | Nothing -> Nothing 83 | Just weapon' -> 84 | Just (EquippedWeapon weapon') 85 | 86 | armor = case model.armor of 87 | Nothing -> Nothing 88 | Just armor' -> 89 | Just (EquippedArmor armor') 90 | 91 | ring = case model.ring of 92 | Nothing -> Nothing 93 | Just ring' -> 94 | Just (EquippedRing ring') 95 | 96 | helm = case model.helm of 97 | Nothing -> Nothing 98 | Just helm' -> 99 | Just (EquippedHelm helm') 100 | 101 | equipment = 102 | [ weapon 103 | , armor 104 | , helm 105 | , ring 106 | ] 107 | in 108 | equipment 109 | |> List.filterMap identity 110 | |> List.map asItem 111 | 112 | itemAtIndex : Int -> Model -> Maybe Item 113 | itemAtIndex idx model = 114 | let 115 | equipment = 116 | equippedItems model 117 | 118 | gearCount = 119 | List.length equipment 120 | in 121 | if idx < List.length equipment then 122 | Util.getAt equipment idx 123 | else 124 | model |> organizedItemAt (idx - gearCount) 125 | 126 | -- VIEW 127 | 128 | view : Point -> Language -> Language -> Maybe Action -> Model -> List (Svg.Svg a) 129 | view (x,y) vocab lang action model = 130 | let 131 | act = 132 | not (action == Nothing) 133 | 134 | header = 135 | [ Graphics.render "GEAR" (x, y) Palette.secondaryLighter ] 136 | 137 | equipment = 138 | equipmentView (x,y+2) vocab lang action model 139 | 140 | hr = 141 | horizontalRule (x,y+2+equipCount) 142 | 143 | equipCount = 144 | List.length equipment 145 | 146 | items = 147 | List.map2 (\n (ct,it) -> 148 | itemView (x,y+3) vocab lang action n ct False it 149 | ) [equipCount..30] (model |> organize |> Dict.values) 150 | 151 | in 152 | header 153 | ++ equipment 154 | ++ hr 155 | ++ items 156 | 157 | horizontalRule (x,y) = 158 | [ Graphics.render "---" (x,y) Palette.dim ] 159 | 160 | equipmentView : Point -> Language -> Language -> Maybe Action -> Warrior.Model -> List (Svg.Svg a) 161 | equipmentView (x,y) vocab language action model = 162 | model 163 | |> equippedItems 164 | |> List.indexedMap (\n item -> itemView (x,y) vocab language action n 1 True item) 165 | 166 | itemView: Point -> Language -> Language -> Maybe Action -> Int -> Int -> Bool -> Item -> Svg.Svg a 167 | itemView (x,y) vocab lang action idx count equipped item = 168 | let 169 | message = 170 | itemMessage vocab lang idx action equipped item 171 | 172 | desc = 173 | if count > 1 then 174 | message ++ " (x" ++ (toString count) ++ ")" 175 | else 176 | message 177 | 178 | color = 179 | itemColor action equipped item 180 | 181 | in 182 | Graphics.render desc (x,y+idx) color 183 | 184 | itemColor action equipped item = 185 | case action of 186 | Nothing -> 187 | Palette.active 188 | 189 | Just act -> 190 | if act |> Action.canPerform equipped item then 191 | if act == Action.drop then 192 | Palette.warning 193 | else 194 | Palette.active 195 | else 196 | Palette.inactive 197 | 198 | itemMessage : Language -> Language -> Int -> Maybe Action -> Bool -> Item -> String 199 | itemMessage vocab lang n action equipped item = 200 | case action of 201 | Nothing -> 202 | "- " 203 | ++ Item.describe vocab lang item 204 | Just action' -> 205 | "(" 206 | ++ Util.toAlpha n 207 | ++ ") " 208 | ++ Action.describeWithDefault item equipped action' 209 | ++ " " 210 | ++ Item.describe vocab lang item 211 | -------------------------------------------------------------------------------- /Room.elm: -------------------------------------------------------------------------------- 1 | module Room exposing (Room, Purpose(..), generate, overlaps, layout, filterOverlaps, network, directionBetween, distance, center, corridor, assign, armory, barracks, library, miningCamp) 2 | 3 | import Point exposing (Point) 4 | import Direction exposing (Direction(..)) 5 | import Graph exposing (Graph) 6 | import Util 7 | import Configuration 8 | import Bresenham 9 | 10 | import Random 11 | import Set exposing (Set) 12 | 13 | type Purpose = Armory 14 | | Barracks 15 | | Library 16 | | MiningCamp 17 | --| TreasureRoom 18 | 19 | armory = 20 | Armory 21 | 22 | barracks = 23 | Barracks 24 | 25 | library = 26 | Library 27 | 28 | miningCamp = 29 | MiningCamp 30 | 31 | type alias Room = { origin : Point 32 | , width : Int 33 | , height : Int 34 | , purpose : Maybe Purpose 35 | , id : Int 36 | } 37 | 38 | generate : Int -> Random.Generator (List Room) 39 | generate n = 40 | generate' |> Random.list n 41 | 42 | generate' : Random.Generator Room 43 | generate' = 44 | let 45 | width' = 46 | Configuration.maxRoomWidth 47 | 48 | height' = 49 | Configuration.maxRoomHeight 50 | 51 | vWidth = 52 | Configuration.viewWidth - 30 53 | 54 | vHeight = 55 | Configuration.viewHeight - 20 56 | 57 | width = 58 | Random.int 5 width' 59 | 60 | height = 61 | Random.int 5 height' 62 | 63 | origin = 64 | Point.randomWithOffset (6,6) (vWidth-width') (vHeight-height') 65 | 66 | in 67 | Random.map3 create origin width height 68 | 69 | create : Point -> Int -> Int -> Room 70 | create point width height = 71 | { origin = point 72 | , width = width 73 | , height = height 74 | , purpose = Nothing 75 | , id = -1 76 | } 77 | 78 | assign purpose room = 79 | { room | purpose = Just purpose } 80 | 81 | overlaps : Room -> Room -> Bool 82 | overlaps a b = 83 | overlapsY -1 a b && overlapsX -1 a b 84 | 85 | overlapsRelevantDirection : Int -> Room -> Room -> Bool 86 | overlapsRelevantDirection n a b = 87 | case directionBetween a b of 88 | North -> overlapsX n a b 89 | South -> overlapsX n a b 90 | East -> overlapsY n a b 91 | West -> overlapsY n a b 92 | _ -> False 93 | 94 | overlapsY n a b = 95 | not (isAbove n a b || isBelow n a b) 96 | 97 | overlapsX n a b = 98 | not (isLeft n a b || isRight n a b) 99 | 100 | isAbove : Int -> Room -> Room -> Bool 101 | isAbove n a b = 102 | let 103 | (_,ay) = a.origin 104 | (_,by) = b.origin 105 | in 106 | ay + a.height < by - n 107 | 108 | isBelow : Int -> Room -> Room -> Bool 109 | isBelow n a b = 110 | let 111 | (_,ay) = a.origin 112 | (_,by) = b.origin 113 | in 114 | by + b.height < ay - n 115 | 116 | isLeft : Int -> Room -> Room -> Bool 117 | isLeft n a b = 118 | let 119 | (ax,_) = a.origin 120 | (bx,_) = b.origin 121 | in 122 | ax + a.width < bx - n 123 | 124 | isRight : Int -> Room -> Room -> Bool 125 | isRight n a b = 126 | let 127 | (ax,_) = a.origin 128 | (bx,_) = b.origin 129 | in 130 | bx + b.width < ax - n 131 | 132 | layout : Room -> (Set Point, Set Point) 133 | layout {origin,width,height} = 134 | layout' origin width height 135 | 136 | layout' (x,y) width height = 137 | let 138 | walls = 139 | Point.perimeter (x,y) width height 140 | 141 | floors = 142 | Point.grid (x+1,y+1) (width-2) (height-2) 143 | in 144 | (walls,floors) 145 | 146 | size : Room -> Int 147 | size r = r.width * r.height 148 | 149 | filterOverlaps : List Room -> List Room 150 | filterOverlaps rooms = 151 | let rooms' = rooms |> List.sortBy size |> List.reverse in 152 | case (List.head rooms') of 153 | Nothing -> 154 | [] 155 | 156 | Just room -> 157 | let 158 | rest = 159 | rooms' 160 | |> List.tail 161 | |> Maybe.withDefault [] 162 | |> List.filter (\room' -> (not (overlaps room room'))) 163 | |> filterOverlaps 164 | in 165 | [room] ++ rest 166 | 167 | center : Room -> Point 168 | center {origin,width,height} = 169 | let (x,y) = origin in 170 | ( x + width // 2 , y + height // 2 ) 171 | 172 | distance : Room -> Room -> Float 173 | distance a b = 174 | Point.distance (center a) (center b) 175 | 176 | corridor : Room -> Room -> List Point 177 | corridor a b = 178 | case corridorEndpoints a b of 179 | Just (pos,pos') -> 180 | Bresenham.line pos pos' 181 | 182 | Nothing -> 183 | [] 184 | 185 | corridorEndpoints : Room -> Room -> Maybe (Point,Point) 186 | corridorEndpoints a b = 187 | let 188 | direction = 189 | directionBetween a b 190 | |> Direction.invert 191 | 192 | (ax,ay) = 193 | a.origin 194 | 195 | (bx,by) = 196 | b.origin 197 | 198 | xOverlapStart = 199 | (max ax bx) + 1 200 | 201 | xOverlapEnd = 202 | (min (ax+a.width) (bx+b.width)) - 1 203 | 204 | xOverlapRange = 205 | [(xOverlapStart)..(xOverlapEnd)] 206 | 207 | sampleOverlap = \overlap -> 208 | Util.sample a.height bx -1 overlap 209 | 210 | yOverlapStart = 211 | (max ay by) + 1 212 | 213 | yOverlapEnd = 214 | (min (ay+a.height) (by+b.height)) - 1 215 | 216 | yOverlapRange = 217 | [(yOverlapStart)..(yOverlapEnd)] 218 | in 219 | case direction of 220 | North -> 221 | Just ((sampleOverlap xOverlapRange, ay), 222 | (sampleOverlap xOverlapRange, by+b.height)) 223 | 224 | South -> 225 | Just ((sampleOverlap xOverlapRange, ay+a.height), 226 | (sampleOverlap xOverlapRange, by)) 227 | 228 | East -> 229 | Just ((ax+a.width, sampleOverlap yOverlapRange), 230 | (bx, sampleOverlap yOverlapRange)) 231 | 232 | West -> 233 | Just ((ax, sampleOverlap yOverlapRange), 234 | (bx+b.width, sampleOverlap yOverlapRange)) 235 | 236 | _ -> 237 | Nothing 238 | 239 | canConnect : Room -> Room -> Bool 240 | canConnect a b = 241 | overlapsRelevantDirection -2 a b 242 | 243 | network : List Room -> Maybe (Graph Room) 244 | network rooms = 245 | Graph.tree distance canConnect rooms 246 | 247 | directionBetween : Room -> Room -> Direction 248 | directionBetween a b = 249 | Point.towards' (center a) (center b) 250 | -------------------------------------------------------------------------------- /game.elm: -------------------------------------------------------------------------------- 1 | import Direction exposing (Direction(..)) 2 | import Engine exposing (Engine) 3 | import World 4 | import Dungeon exposing (Dungeon) 5 | import Entity exposing (Entity) 6 | import Graphics 7 | import Configuration 8 | import Event exposing (Event(..)) 9 | import Palette 10 | import Language exposing (Language) 11 | import Point exposing (Point) 12 | 13 | import Char 14 | import Task 15 | import Random 16 | import String 17 | 18 | import Time exposing (Time, millisecond) 19 | import Keyboard exposing (KeyCode) 20 | import Mouse 21 | import Window 22 | 23 | import Html exposing (Html) 24 | import Html.App as App 25 | import Html.Attributes exposing (type', style) 26 | 27 | import Svg exposing (svg, rect, text') 28 | import Svg.Attributes exposing (viewBox, width, height, x, y, fontSize, fontFamily, preserveAspectRatio) 29 | import Svg.Events 30 | 31 | -- MAIN 32 | main = 33 | App.program 34 | { init = init 35 | , view = view 36 | , update = update 37 | , subscriptions = subscriptions 38 | } 39 | 40 | -- MODEL 41 | 42 | type GameState = Splash 43 | | Generating 44 | | Playing 45 | | Death String 46 | | Victory 47 | 48 | type alias Model = 49 | { engine : Engine 50 | , state : GameState 51 | , generationUnderway : Bool 52 | , ticks : Int 53 | , autoplay : Bool 54 | , width : Int 55 | , height : Int 56 | } 57 | 58 | -- INIT 59 | init : (Model, Cmd Msg) 60 | init = ( { engine = Engine.init 61 | , state = Splash 62 | , generationUnderway = False 63 | , ticks = 0 64 | , autoplay = False 65 | , width = 0 66 | , height = 0 67 | }, 68 | --Cmd.none 69 | Task.perform (\_ -> NoOp) sizeToMsg Window.size 70 | ) 71 | 72 | generateMap : Cmd Msg 73 | generateMap = 74 | Random.generate MapMsg (Dungeon.generate Configuration.levelCount) 75 | 76 | generateLanguage : Cmd Msg 77 | generateLanguage = 78 | Random.generate LangMsg (Language.generate) 79 | 80 | -- TYPES 81 | type Msg 82 | = KeyMsg KeyCode 83 | | HoverMsg Mouse.Position 84 | | ClickMsg Mouse.Position 85 | | TickMsg Time 86 | | MapMsg Dungeon 87 | | LangMsg Language 88 | | ResizeWindow (Int, Int) 89 | | NoOp 90 | 91 | -- UPDATE 92 | update : Msg -> Model -> (Model, Cmd Msg) 93 | update message model = 94 | case message of 95 | NoOp -> 96 | (model, Cmd.none) 97 | 98 | ResizeWindow (width, height) -> 99 | ({ model | width = width, height = height }, Cmd.none) 100 | 101 | MapMsg dungeon -> 102 | ({ model | engine = (model.engine |> Engine.enter dungeon) 103 | }, generateLanguage) 104 | 105 | LangMsg language -> 106 | ({ model | engine = model.engine |> Engine.speak language 107 | , state = Playing 108 | }, Cmd.none) 109 | 110 | ClickMsg position -> 111 | ({ model | engine = (model.engine |> Engine.clickAt position) }, Cmd.none) 112 | 113 | HoverMsg position -> 114 | ({ model | engine = (model.engine |> Engine.hoverAt (pointFromMouse position model)) }, Cmd.none) 115 | 116 | TickMsg time -> 117 | case model.state of 118 | Playing -> 119 | let 120 | model' = if model.autoplay then 121 | { model | engine = model.engine |> Engine.autorogue 122 | , ticks = 0 123 | , autoplay = False } 124 | else 125 | model 126 | in 127 | ({ model' | engine = (model'.engine |> Engine.tick time) } 128 | |> inferState 129 | , Cmd.none) 130 | 131 | Generating -> 132 | if model.generationUnderway then 133 | (model, Cmd.none) 134 | else 135 | ({ model | generationUnderway = True }, generateMap) 136 | 137 | Splash -> 138 | if model.ticks > 200 then 139 | ({model | autoplay = True} |> startGeneration, Cmd.none) 140 | else 141 | ({ model | ticks = model.ticks + 1}, Cmd.none) 142 | 143 | _ -> (model, Cmd.none) 144 | 145 | KeyMsg keyCode -> 146 | case model.state of 147 | Splash -> 148 | (model |> startGeneration, Cmd.none) 149 | 150 | Death _ -> 151 | ({model | state = Splash}, Cmd.none) 152 | 153 | Victory -> 154 | ({model | state = Splash}, Cmd.none) 155 | 156 | Generating -> 157 | (model, Cmd.none) 158 | 159 | Playing -> 160 | let 161 | keyChar = 162 | Char.fromCode keyCode 163 | 164 | engine' = 165 | model.engine 166 | |> Engine.handleKeypress keyChar 167 | |> Engine.resetHover 168 | in 169 | ({ model | engine = engine' } |> inferState, Cmd.none) 170 | 171 | 172 | pointFromMouse : Mouse.Position -> Model -> Point 173 | pointFromMouse {x,y} model = 174 | if model.height > model.width then 175 | let 176 | scale = 177 | toFloat model.width 178 | 179 | yScale = 180 | (Configuration.viewHeight / (scale * (40/60))) 181 | 182 | xScale = 183 | (Configuration.viewWidth / scale) 184 | in 185 | ( round ((toFloat x)*xScale) , round ((toFloat y)*yScale)) 186 | |> Debug.log "pt" 187 | else 188 | let 189 | scale = 190 | toFloat model.height 191 | 192 | yScale = 193 | (Configuration.viewHeight / scale) 194 | 195 | xScale = 196 | (Configuration.viewWidth / (scale * (60/40))) 197 | in 198 | ( round ((toFloat x)*xScale) , round ((toFloat y)*yScale)) 199 | |> Debug.log "pt" 200 | 201 | startGeneration : Model -> Model 202 | startGeneration model = 203 | {model | state = Generating 204 | , generationUnderway = False 205 | , engine = Engine.init 206 | } 207 | 208 | inferState : Model -> Model 209 | inferState model = 210 | let 211 | won = 212 | model.engine.world.hallsEscaped 213 | 214 | deathEvent = 215 | model.engine.world 216 | |> World.deathEvent 217 | 218 | state' = 219 | if won then 220 | Victory 221 | else 222 | case deathEvent of 223 | Just event -> 224 | case event of 225 | Event.Death cause -> 226 | Death cause 227 | _ -> 228 | Death "unknown causes" 229 | 230 | Nothing -> 231 | Playing 232 | 233 | in 234 | { model | state = state' } 235 | 236 | -- SUBS 237 | subscriptions : Model -> Sub Msg 238 | subscriptions model = 239 | Sub.batch 240 | [ Mouse.moves HoverMsg 241 | , Mouse.clicks ClickMsg 242 | , Keyboard.presses KeyMsg 243 | , Time.every Configuration.tickInterval TickMsg 244 | , Window.resizes sizeToMsg 245 | ] 246 | 247 | sizeToMsg : Window.Size -> Msg 248 | sizeToMsg size = 249 | ResizeWindow (size.width, size.height) 250 | 251 | 252 | -- VIEW 253 | view : Model -> Html Msg 254 | view model = 255 | let 256 | bgStyle = [ 257 | ( "background-color", "black" 258 | ) 259 | ] 260 | in 261 | Html.div [ style bgStyle ] 262 | [ Html.node "style" [type' "text/css"] [Html.text "@import 'https://fonts.googleapis.com/css?family=VT323'"] 263 | , box (stateView model) model 264 | ] 265 | 266 | box viewModel model = 267 | let 268 | dims = 269 | [0,0,Configuration.viewWidth,Configuration.viewHeight] 270 | |> List.map toString 271 | |> String.join " " 272 | in 273 | svg [ viewBox dims 274 | , style [("height", (toString model.height)) 275 | ,("width", (toString model.width))] 276 | , preserveAspectRatio "xMinYMin" 277 | ] 278 | viewModel 279 | 280 | stateView model = 281 | let 282 | hero = 283 | Graphics.hero "MANDOS" 20 284 | 285 | jumbo = 286 | Graphics.jumbo "@" 287 | 288 | anyKey = 289 | Graphics.render "press any key to play" (42, 36) Palette.bright 290 | 291 | trademark = 292 | Graphics.render "Written by Joseph Weissman // A Deep Cerulean Experience" (34, 38) Palette.tertiaryLighter 293 | 294 | steps = 295 | model.engine.world.player.steps 296 | 297 | kills = 298 | model.engine.world.events 299 | |> List.filter Event.isEnemyKill 300 | |> List.length 301 | in 302 | case model.state of 303 | Splash -> 304 | [ jumbo 305 | , hero 306 | , anyKey 307 | , trademark 308 | ] 309 | 310 | Generating -> 311 | [ jumbo 312 | , hero 313 | , Graphics.render "Generating world, please wait..." (38, 35) Palette.secondaryLighter 314 | , Graphics.render "(This may take a little while!)" (38, 38) Palette.secondaryLight 315 | ] 316 | 317 | Victory -> 318 | Engine.view model.engine 319 | ++ [ 320 | Graphics.hero "YOU WON!" 20 321 | , Graphics.render "Congratulations!" (34, 30) Palette.secondaryLighter 322 | , Graphics.render "You escaped the Halls of Mandos!" (31, 32) Palette.secondaryLight 323 | , Graphics.render ((toString steps) ++ " steps taken") (38, 36) Palette.secondaryLight 324 | , Graphics.render ((toString kills) ++ " kills") (38, 37) Palette.secondaryLight 325 | ] 326 | 327 | Death cause -> 328 | Engine.view model.engine ++ 329 | [ Graphics.hero "YOU DIED!" 20 330 | , Graphics.render ("You fought bravely, but were " ++ cause) (35, 30) Palette.bright 331 | , Graphics.render ((toString steps) ++ " steps taken") (38, 36) Palette.secondaryLight 332 | , Graphics.render ((toString kills) ++ " kills") (38, 37) Palette.secondaryLight 333 | ] 334 | 335 | Playing -> 336 | Engine.view model.engine 337 | -------------------------------------------------------------------------------- /Warrior.elm: -------------------------------------------------------------------------------- 1 | module Warrior exposing (Model, init, step, vision, strength, takeDamage, enrich, collectsItem, drink, wield, wearArmor, wearHelm, wearRing, computeDamageAgainst, resistance, cardView, augmentVision, sheatheWeapon, takeOffArmor, takeOffHelm, takeOffRing, learnsWord) 2 | 3 | import Configuration 4 | import Util 5 | import Direction exposing (Direction(..)) 6 | import Point exposing (Point, slide) 7 | import Weapon exposing (Weapon) 8 | import Armor exposing (Armor) 9 | import Helm exposing (Helm) 10 | import Ring exposing (Ring) 11 | import Item exposing (Item, ItemKind(..)) 12 | import Action exposing (Action) 13 | import Liquid exposing (Liquid(..)) 14 | import Palette 15 | import Language exposing (Language, Word) 16 | 17 | import Graphics 18 | import Svg 19 | 20 | 21 | import Dict exposing (Dict) 22 | 23 | -- MODEL 24 | 25 | type alias Model = 26 | { hp : Int 27 | , maxHp : Int 28 | , direction : Direction 29 | , position : Point 30 | , gold : Int 31 | , str : Int 32 | , steps : Int 33 | , weapon : Maybe Weapon 34 | , armor : Maybe Armor 35 | , ring : Maybe Ring 36 | , helm : Maybe Helm 37 | , inventory : List Item 38 | , timesGearChanged : Int 39 | , vision : Int 40 | , vocabulary : Language 41 | } 42 | 43 | -- INIT 44 | 45 | init : Point -> Model 46 | init point = 47 | let hp = Configuration.startingHitPoints in 48 | { hp = hp 49 | , maxHp = hp 50 | , direction = North 51 | , position = point 52 | , gold = 0 53 | , str = Configuration.startingStrength 54 | , steps = 0 55 | , weapon = Nothing 56 | , armor = Nothing 57 | , ring = Nothing 58 | , helm = Nothing 59 | , inventory = [] 60 | , timesGearChanged = 0 61 | , vision = Configuration.visionRadius 62 | , vocabulary = [] 63 | } 64 | 65 | vision : Model -> Int 66 | vision model = 67 | let 68 | ringBonus = 69 | case model.ring of 70 | Nothing -> 71 | 0 72 | Just ring -> 73 | Ring.visionBonus ring 74 | in 75 | model.vision + ringBonus 76 | 77 | strength : Model -> Int 78 | strength model = 79 | let 80 | ringBonus = 81 | case model.ring of 82 | Nothing -> 83 | 0 84 | Just ring -> 85 | Ring.strengthBonus ring 86 | in 87 | model.str + ringBonus 88 | 89 | power : Model -> Int 90 | power model = 91 | let 92 | weaponBonus = 93 | case model.weapon of 94 | Nothing -> 95 | 0 96 | 97 | Just weapon -> 98 | (Weapon.averageDamage weapon) 99 | in 100 | (strength model) + weaponBonus 101 | 102 | resistance : Model -> Int 103 | resistance model = 104 | let 105 | armorBonus = 106 | case model.armor of 107 | Nothing -> 108 | 0 109 | 110 | Just armor -> 111 | Armor.absorption armor 112 | 113 | helmBonus = 114 | case model.helm of 115 | Nothing -> 116 | 0 117 | 118 | Just helm -> 119 | Helm.absorption helm 120 | 121 | in (strength model) + armorBonus + helmBonus 122 | 123 | -- helpers 124 | step : Direction -> Model -> Model 125 | step direction model = 126 | let model' = { model | position = model.position |> slide direction 127 | , steps = model.steps + 1 128 | } 129 | in 130 | if model.steps % 10 == 0 then 131 | model' |> heal 1 132 | else 133 | model' 134 | 135 | computeDamageAgainst : Int -> Model -> Int 136 | computeDamageAgainst defense model = 137 | let 138 | damage = case model.weapon of 139 | Just weapon -> 140 | (strength model) + Weapon.damage model.steps model.timesGearChanged weapon 141 | Nothing -> 142 | (strength model) 143 | in 144 | max 1 (damage - defense) 145 | 146 | takeDamage : Int -> Model -> Model 147 | takeDamage amount model = 148 | { model | hp = model.hp - amount } 149 | 150 | enrich : Int -> Model -> Model 151 | enrich amount model = 152 | { model | gold = model.gold + amount } 153 | 154 | heal : Int -> Model -> Model 155 | heal amount model = 156 | { model | hp = min model.maxHp (model.hp + amount) } 157 | 158 | augmentVision : Int -> Model -> Model 159 | augmentVision amount model = 160 | { model | vision = model.vision + amount } 161 | 162 | drink : Liquid -> Model -> Model 163 | drink liquid model = 164 | case liquid of 165 | Liquid.Water -> 166 | model 167 | |> heal 5 168 | 169 | Liquid.Blessed liquid' -> 170 | model 171 | |> heal 10 172 | |> drink liquid' 173 | 174 | Potion effect -> 175 | case effect of 176 | Liquid.GainLife -> 177 | model 178 | |> gainHp 2 179 | 180 | gainHp : Int -> Model -> Model 181 | gainHp n model = 182 | let hp' = model.maxHp + n in 183 | { model | hp = hp' 184 | , maxHp = hp' 185 | } 186 | 187 | addToInventory item model = 188 | let 189 | model' = 190 | { model | inventory = model.inventory ++ [item] 191 | } 192 | in 193 | model' 194 | 195 | wield : Weapon -> Model -> Model 196 | wield weapon model = 197 | case model.weapon of 198 | Just weapon' -> 199 | let oldWeapon = Item.init (0,0) (Item.weapon weapon') (1000000 + model.timesGearChanged) in 200 | { model | weapon = Just weapon 201 | , timesGearChanged = model.timesGearChanged + 1 202 | } 203 | |> addToInventory oldWeapon 204 | 205 | Nothing -> 206 | { model | weapon = Just weapon } 207 | 208 | sheatheWeapon : Model -> Model 209 | sheatheWeapon model = 210 | case model.weapon of 211 | Nothing -> 212 | model 213 | 214 | Just weapon -> 215 | let oldWeapon = Item.init (0,0) (Item.weapon weapon) (1000000 + model.timesGearChanged) in 216 | { model | weapon = Nothing 217 | , timesGearChanged = model.timesGearChanged + 1 218 | } 219 | |> addToInventory oldWeapon 220 | 221 | wearArmor : Armor -> Model -> Model 222 | wearArmor armor model = 223 | case model.armor of 224 | Just armor' -> 225 | let oldArmor = Item.init (0,0) (Item.armor armor') (1000000 + model.timesGearChanged) in 226 | { model | armor = Just armor 227 | , timesGearChanged = model.timesGearChanged + 1 228 | } 229 | |> addToInventory oldArmor 230 | 231 | Nothing -> 232 | { model | armor = Just armor } 233 | 234 | takeOffArmor : Model -> Model 235 | takeOffArmor model = 236 | case model.armor of 237 | Nothing -> 238 | model 239 | 240 | Just armor -> 241 | let oldArmor = Item.init (0,0) (Item.armor armor) (1000000 + model.timesGearChanged) in 242 | { model | armor = Nothing 243 | , timesGearChanged = model.timesGearChanged + 1 244 | } 245 | |> addToInventory oldArmor 246 | 247 | wearHelm : Helm -> Model -> Model 248 | wearHelm helm model = 249 | case model.helm of 250 | Just helm' -> 251 | let oldHelm = Item.init (0,0) (Item.helm helm') (1000000 + model.timesGearChanged) in 252 | { model | helm = Just helm 253 | , timesGearChanged = model.timesGearChanged + 1 254 | } 255 | |> addToInventory oldHelm 256 | 257 | Nothing -> 258 | { model | helm = Just helm } 259 | 260 | takeOffHelm : Model -> Model 261 | takeOffHelm model = 262 | case model.helm of 263 | Nothing -> 264 | model 265 | 266 | Just helm -> 267 | let oldHelm = Item.init (0,0) (Item.helm helm) (1000000 + model.timesGearChanged) in 268 | { model | helm = Nothing 269 | , timesGearChanged = model.timesGearChanged + 1 270 | } 271 | |> addToInventory oldHelm 272 | 273 | 274 | wearRing : Ring -> Model -> Model 275 | wearRing ring model = 276 | case model.ring of 277 | Just ring' -> 278 | let 279 | oldRing = 280 | Item.init (0,0) (Item.ring ring') (1000000 + model.timesGearChanged) 281 | in 282 | { model | ring = Just ring 283 | , timesGearChanged = model.timesGearChanged + 1 284 | } 285 | |> addToInventory oldRing 286 | 287 | Nothing -> 288 | { model | ring = Just ring } 289 | 290 | takeOffRing : Model -> Model 291 | takeOffRing model = 292 | case model.ring of 293 | Nothing -> 294 | model 295 | 296 | Just ring -> 297 | let oldRing = Item.init (0,0) (Item.ring ring) (1000000 + model.timesGearChanged) in 298 | { model | ring = Nothing 299 | , timesGearChanged = model.timesGearChanged + 1 300 | } 301 | |> addToInventory oldRing 302 | 303 | collectsItem : Item -> Model -> Model 304 | collectsItem item model = 305 | let 306 | model' = 307 | model |> addToInventory item 308 | in 309 | case item.kind of 310 | Arm weapon -> 311 | case model.weapon of 312 | Nothing -> 313 | model |> wield weapon 314 | Just weapon' -> 315 | model' 316 | 317 | Shield armor -> 318 | case model.armor of 319 | Nothing -> 320 | model |> wearArmor armor 321 | Just armor' -> 322 | model' 323 | 324 | Headgear helm -> 325 | case model.helm of 326 | Nothing -> 327 | model |> wearHelm helm 328 | Just helm' -> 329 | model' 330 | 331 | _ -> 332 | model' 333 | 334 | learnsWord : Word -> Model -> Model 335 | learnsWord word model = 336 | if List.member word model.vocabulary then 337 | model 338 | else 339 | { model | vocabulary = word :: model.vocabulary } 340 | 341 | -- VIEW 342 | cardView : Point -> Maybe Action -> Model -> List (Svg.Svg a) 343 | cardView (x,y) action model = 344 | let 345 | strength = 346 | toString (power model) 347 | 348 | resist = 349 | toString (resistance model) 350 | 351 | in 352 | [ Graphics.render "STATS" (x, y) Palette.primaryLighter 353 | , Graphics.render (" STRENGTH: " ++ strength) (x, y+2) Palette.active 354 | , Graphics.render ("RESISTANCE: " ++ resist) (x, y+3) Palette.active 355 | ] 356 | -------------------------------------------------------------------------------- /World.elm: -------------------------------------------------------------------------------- 1 | module World exposing (Model, init, view, playerSteps, floors, walls, doors, coins, downstairs, upstairs, entrances, crystals, playerViewsField, playerDropsItem, entityAt, viewed, canPlayerStep, creatures, items, doesPlayerHaveCrystal, augmentVision, enchantItem, playerSheathesWeapon, playerTakesOff, playerWields, playerWears, playerDrinks, deathEvent, viewFrontier, playerLearnsWord, hitCreatureAt) 2 | 3 | import Palette 4 | import Point exposing (Point, slide) 5 | import Direction exposing (Direction) 6 | import Optics 7 | import Creature 8 | import Warrior 9 | import Weapon 10 | import Armor 11 | import Ring 12 | import Helm 13 | import Entity exposing (Entity) 14 | import Room exposing (Room) 15 | import Dungeon exposing (Dungeon) 16 | import Level exposing (Level) 17 | import Path 18 | import Log 19 | import Event exposing (..) 20 | import Util 21 | import Configuration 22 | import Item exposing (Item) 23 | import Inventory 24 | import Spell exposing (Spell(..)) 25 | import Language exposing (Language, Word) 26 | import Liquid 27 | 28 | import Set exposing (Set) 29 | import String 30 | import Html 31 | import Graphics 32 | import Svg 33 | import Random 34 | 35 | type alias Model = 36 | { 37 | depth : Int 38 | , dungeon : Dungeon 39 | , player : Warrior.Model 40 | , events : Log.Model 41 | , debugPath : List Point 42 | , illuminated : Set Point 43 | , hallsEscaped : Bool 44 | , showMap : Bool 45 | , age : Int 46 | , language : Language 47 | , animateEntities : List Entity 48 | } 49 | 50 | -- INIT 51 | init : Model 52 | init = 53 | { 54 | dungeon = [] 55 | , depth = 0 56 | , player = Warrior.init (0,0) 57 | , events = Log.init 58 | , debugPath = [] 59 | , illuminated = Set.empty --[] 60 | , hallsEscaped = False 61 | , showMap = False 62 | , age = 0 63 | , language = [] 64 | , animateEntities = [] 65 | } 66 | 67 | 68 | level : Model -> Level 69 | level model = 70 | Util.getAt model.dungeon model.depth 71 | |> Maybe.withDefault Level.init 72 | 73 | viewed : Model -> Set Point 74 | viewed model = 75 | let lvl = (level model) in 76 | lvl.viewed 77 | 78 | walls : Model -> Set Point 79 | walls model = 80 | (level model).walls 81 | 82 | coins : Model -> List Point 83 | coins model = 84 | (level model).coins 85 | |> Set.toList 86 | 87 | creatures : Model -> List Creature.Model 88 | creatures model = 89 | (level model).creatures 90 | 91 | items : Model -> List Item 92 | items model = 93 | (level model).items 94 | 95 | doors : Model -> Set Point 96 | doors model = 97 | (level model).doors 98 | 99 | floors : Model -> Set Point 100 | floors model = 101 | (level model).floors 102 | 103 | upstairs : Model -> List Point 104 | upstairs model = 105 | case (level model).upstairs of 106 | Just pt -> [pt] 107 | Nothing -> [] 108 | 109 | downstairs : Model -> List Point 110 | downstairs model = 111 | case (level model).downstairs of 112 | Just pt -> [pt] 113 | Nothing -> [] 114 | 115 | entrances : Model -> List Point 116 | entrances model = 117 | case (level model).entrance of 118 | Just (pt,_) -> [pt] 119 | Nothing -> [] 120 | 121 | crystals : Model -> List Point 122 | crystals model = 123 | let location = (level model) |> Level.crystalLocation in 124 | case location of 125 | Just pt -> [pt] 126 | Nothing -> [] 127 | 128 | -- PREDICATES/QUERIES 129 | 130 | isPlayer : Point -> Model -> Bool 131 | isPlayer position model = 132 | model.player.position == position 133 | 134 | entityAt : Point -> Model -> Maybe Entity 135 | entityAt pt model = 136 | Level.entityAt pt (level model) 137 | 138 | -- PLAYER STEP 139 | playerSteps : Direction -> Model -> Model 140 | playerSteps direction model = 141 | model 142 | |> playerDestroysWalls direction 143 | |> playerMoves direction 144 | |> playerAttacks direction 145 | |> evolve 146 | 147 | age : Model -> Model 148 | age model = 149 | { model | age = model.age + 1 } 150 | 151 | evolve : Model -> Model 152 | evolve model = 153 | if model.age % 250 == 0 then 154 | { model | dungeon = model.dungeon |> Dungeon.evolve } 155 | |> age 156 | else 157 | model 158 | |> age 159 | 160 | playerMoves : Direction -> Model -> Model 161 | playerMoves direction model = 162 | if (canPlayerStep direction model) then 163 | { model | player = (Warrior.step direction model.player) } 164 | |> playerAscendsOrDescends 165 | |> playerEscapesHall 166 | |> playerCollectsCoins 167 | |> playerCollectsItems 168 | else 169 | model 170 | 171 | canPlayerStep : Direction -> Model -> Bool 172 | canPlayerStep direction model = 173 | let 174 | move = 175 | model.player.position 176 | |> slide direction 177 | in 178 | not ( Level.isCreature move (level model) || Set.member move (walls model)) 179 | 180 | playerCollectsCoins : Model -> Model 181 | playerCollectsCoins model = 182 | let 183 | isCoin = 184 | level model 185 | |> Level.isCoin model.player.position 186 | 187 | dungeon' = 188 | model.dungeon 189 | |> Dungeon.collectCoin model.player.position model.depth 190 | in 191 | if (not isCoin) then 192 | model 193 | else 194 | let event = Event.pickupCoin in 195 | { model | player = Warrior.enrich 1 model.player 196 | , dungeon = dungeon' 197 | , events = model.events ++ [event] 198 | } 199 | 200 | doesPlayerHaveCrystal model = 201 | model.player.inventory 202 | |> List.any (\{kind} -> kind == Item.crystal) 203 | 204 | playerEscapesHall : Model -> Model 205 | playerEscapesHall model = 206 | let 207 | isEntrance = 208 | level model 209 | |> Level.isEntrance model.player.position 210 | 211 | in 212 | if (model |> doesPlayerHaveCrystal) && isEntrance then 213 | let event = Event.hallsEscaped in 214 | { model | hallsEscaped = True 215 | , events = model.events ++ [event] 216 | } 217 | else 218 | model 219 | 220 | playerAttacks : Direction -> Model -> Model 221 | playerAttacks direction model = 222 | let 223 | {player} = 224 | model 225 | 226 | attackedPositions = 227 | case player.weapon of 228 | Just weapon -> 229 | Weapon.threatRange player.position direction weapon 230 | 231 | Nothing -> 232 | [ player.position |> slide direction ] 233 | 234 | creatures = 235 | attackedPositions 236 | |> List.map (\pt -> (level model) |> Level.creatureAt pt) 237 | |> List.filterMap identity 238 | in 239 | creatures 240 | |> List.foldr (\creature -> playerAttacksCreature creature) model 241 | |> removeDeceasedCreatures 242 | 243 | playerAttacksCreature : Creature.Model -> Model -> Model 244 | playerAttacksCreature creature model = 245 | let 246 | damage = 247 | Warrior.computeDamageAgainst creature.defense model.player 248 | in 249 | model 250 | |> creatureTakesDamage creature damage 251 | 252 | creatureTakesDamage : Creature.Model -> Int -> Model -> Model 253 | creatureTakesDamage creature amount model = 254 | let 255 | dungeon' = 256 | model.dungeon 257 | |> Dungeon.injureCreature creature amount model.depth 258 | 259 | attackEvent = 260 | Event.attack creature amount 261 | in 262 | { model | dungeon = dungeon' 263 | , events = model.events ++ [attackEvent] 264 | } 265 | 266 | removeDeceasedCreatures : Model -> Model 267 | removeDeceasedCreatures model = 268 | let 269 | (dungeon', events') = 270 | Dungeon.purge model.depth model.dungeon 271 | in 272 | { model | dungeon = dungeon' 273 | , events = model.events ++ events' } 274 | 275 | playerDestroysWalls : Direction -> Model -> Model 276 | playerDestroysWalls direction model = 277 | let 278 | pt = 279 | model.player.position 280 | |> Point.slide direction 281 | 282 | isWall = 283 | Set.member pt (walls model) 284 | 285 | destructive = 286 | case model.player.weapon of 287 | Just weapon -> 288 | Weapon.destroyWalls weapon 289 | Nothing -> 290 | False 291 | 292 | dungeon' = 293 | model.dungeon 294 | |> Dungeon.playerDestroysWall pt model.depth 295 | 296 | in 297 | if isWall && destructive then 298 | { model | dungeon = dungeon' 299 | , player = model.player |> Warrior.step direction } 300 | else 301 | model 302 | 303 | playerAscendsOrDescends : Model -> Model 304 | playerAscendsOrDescends model = 305 | let 306 | playerPos = 307 | model.player.position 308 | in 309 | if List.member playerPos (downstairs model) && model.depth < ((List.length model.dungeon) - 1) then 310 | model |> playerDescends 311 | else 312 | if List.member playerPos (upstairs model) && model.depth > 0 then 313 | model |> playerAscends 314 | else 315 | model 316 | 317 | playerAscends : Model -> Model 318 | playerAscends model = 319 | let 320 | player = 321 | model.player 322 | 323 | model' = 324 | { model | depth = model.depth - 1 } 325 | 326 | player' = 327 | { player | position = (downstairs model') |> List.head |> Maybe.withDefault (0,0) } 328 | 329 | events' = 330 | model.events ++ [Event.ascend (model.depth-1)] 331 | in 332 | { model' | player = player' } 333 | 334 | playerDescends : Model -> Model 335 | playerDescends model = 336 | let 337 | player = 338 | model.player 339 | 340 | model' = 341 | { model | depth = model.depth + 1 } 342 | 343 | player' = 344 | { player | position = (upstairs model') |> List.head |> Maybe.withDefault (0,0) } 345 | 346 | events' = 347 | model.events ++ [Event.descend (model.depth+1)] 348 | in 349 | { model' | player = player', events = events' } 350 | 351 | playerViewsField : Model -> Model 352 | playerViewsField model = 353 | let 354 | source = 355 | model.player.position 356 | 357 | locations = 358 | model |> illuminate source 359 | in 360 | { model | dungeon = model.dungeon |> Dungeon.playerSees locations model.depth 361 | , illuminated = locations 362 | } 363 | 364 | illuminate : Point -> Model -> Set Point 365 | illuminate source model = 366 | let 367 | perimeter = 368 | Point.perimeter (1,1) Configuration.viewWidth Configuration.viewHeight 369 | |> Set.toList 370 | 371 | blockers = 372 | (creatures model) 373 | |> List.map .position 374 | |> Set.fromList 375 | |> Set.union (Set.union (walls model) (doors model)) 376 | 377 | power = 378 | Warrior.vision model.player 379 | 380 | in 381 | source 382 | |> Optics.illuminate power perimeter blockers 383 | 384 | playerCollectsItems : Model -> Model 385 | playerCollectsItems model = 386 | if Inventory.size model.player < Configuration.inventoryLimit then 387 | case (level model) |> Level.itemAt (model.player.position) of 388 | Nothing -> 389 | model 390 | 391 | Just item -> 392 | let event = Event.pickupItem item in 393 | { model | player = Warrior.collectsItem item model.player 394 | , dungeon = model.dungeon |> Dungeon.removeItem item model.depth 395 | , events = model.events ++ [ event ] 396 | } 397 | else 398 | model 399 | 400 | playerDropsItem : Item -> Model -> Model 401 | playerDropsItem item model = 402 | let 403 | inventory' = 404 | model.player.inventory 405 | |> List.filter (\it -> not (it == item)) 406 | 407 | player = 408 | model.player 409 | 410 | player' = 411 | { player | inventory = inventory' } 412 | in 413 | { model | player = player' } 414 | 415 | playerWields : Item -> Model -> Model 416 | playerWields item model = 417 | case item.kind of 418 | Item.Arm weapon -> 419 | { model | player = model.player |> Warrior.wield weapon } 420 | 421 | _ -> model 422 | 423 | playerWears : Item -> Model -> Model 424 | playerWears item model = 425 | case item.kind of 426 | Item.Shield armor -> 427 | { model | player = model.player |> Warrior.wearArmor armor } 428 | 429 | Item.Jewelry ring -> 430 | let 431 | player' = 432 | model.player 433 | |> Warrior.wearRing ring 434 | 435 | word = 436 | model.language 437 | |> Language.wordFor (Spell.idea (Ring.spell ring)) 438 | in 439 | { model | player = player' } 440 | |> playerViewsField -- could be ring of light.. 441 | |> playerLearnsWord word 442 | 443 | Item.Headgear helm -> 444 | { model | player = model.player |> Warrior.wearHelm helm } 445 | 446 | _ -> model 447 | 448 | playerTakesOff item model = 449 | case item.kind of 450 | Item.Shield armor -> 451 | { model | player = model.player |> Warrior.takeOffArmor } 452 | 453 | Item.Jewelry ring -> 454 | { model | player = model.player |> Warrior.takeOffRing } 455 | |> playerViewsField 456 | 457 | Item.Headgear helm -> 458 | { model | player = model.player |> Warrior.takeOffHelm } 459 | 460 | _ -> model 461 | 462 | 463 | playerDrinks : Item -> Model -> Model 464 | playerDrinks item model = 465 | case item.kind of 466 | Item.Bottle liquid -> 467 | let 468 | player' = 469 | model.player 470 | |> Warrior.drink liquid 471 | 472 | word = 473 | Language.wordFor (Liquid.idea liquid) model.language 474 | in 475 | { model | player = player' } 476 | |> playerLearnsWord word 477 | 478 | _ -> model 479 | 480 | playerLearnsWord : Word -> Model -> Model 481 | playerLearnsWord word model = 482 | { model | player = model.player |> Warrior.learnsWord word } 483 | 484 | playerSheathesWeapon : Model -> Model 485 | playerSheathesWeapon model = 486 | { model | player = model.player |> Warrior.sheatheWeapon } 487 | 488 | augmentVision : Model -> Model 489 | augmentVision model = 490 | { model | player = model.player |> Warrior.augmentVision 1 } 491 | 492 | enchantItem : Item -> Model -> Model 493 | enchantItem item model = 494 | let 495 | player = 496 | model.player 497 | 498 | inventory' = 499 | player.inventory 500 | |> List.map (\it -> if it == item then Item.enchant it else it) 501 | 502 | weapon' = 503 | case player.weapon of 504 | Just weapon -> 505 | if Item.simple (Item.weapon weapon) == item then 506 | Just (Weapon.enchant weapon) 507 | else 508 | Just weapon 509 | 510 | Nothing -> 511 | Nothing 512 | 513 | armor' = 514 | case player.armor of 515 | Just armor -> 516 | if Item.simple (Item.armor armor) == item then 517 | Just (Armor.enchant armor) 518 | else 519 | Just armor 520 | 521 | Nothing -> 522 | Nothing 523 | 524 | ring' = 525 | case player.ring of 526 | Just ring -> 527 | if Item.simple (Item.ring ring) == item then 528 | Just (Ring.enchant ring) 529 | else 530 | Just ring 531 | Nothing -> 532 | Nothing 533 | 534 | helm' = 535 | case player.helm of 536 | Just helm -> 537 | if Item.simple (Item.helm helm) == item then 538 | Just (Helm.enchant helm) 539 | else 540 | Just helm 541 | 542 | Nothing -> 543 | Nothing 544 | 545 | player' = 546 | { player | inventory = inventory' 547 | , armor = armor' 548 | , weapon = weapon' 549 | , ring = ring' 550 | , helm = helm' 551 | } 552 | in 553 | { model | player = player' } 554 | |> playerViewsField -- could be enchanting ring of light.. 555 | 556 | 557 | hitCreatureAt : Point -> Item -> Model -> Model 558 | hitCreatureAt pt item model = 559 | case (level model) |> Level.creatureAt pt of 560 | Just creature -> 561 | let 562 | (dungeon', events) = 563 | model.dungeon 564 | |> Dungeon.apply (Level.hitCreatureWith item creature) model.depth 565 | |> Dungeon.purge model.depth 566 | -- todo need event here if we hit something... 567 | 568 | newEvents = 569 | (Event.attack creature (Item.thrownDamage item)) :: events 570 | 571 | model' = 572 | { model | dungeon = dungeon' 573 | , events = model.events ++ newEvents 574 | } 575 | in 576 | -- we could have killed a creature (destroyed a view obstacle) 577 | model' 578 | |> playerViewsField 579 | 580 | Nothing -> 581 | model 582 | 583 | --model 584 | 585 | deathEvent : Model -> Maybe Event 586 | deathEvent model = 587 | model.events 588 | |> List.filter (Event.isPlayerDeath) 589 | |> List.head 590 | 591 | 592 | viewFrontier : Model -> Set Point 593 | viewFrontier model = 594 | model.dungeon 595 | |> Dungeon.viewFrontier model.depth 596 | 597 | -- VIEW 598 | listInvisibleEntities : Model -> List Entity 599 | listInvisibleEntities model = 600 | if not model.showMap then 601 | [] 602 | else 603 | let explorable = (Set.union (model |> floors) (model |> walls)) in 604 | viewed model 605 | |> Set.diff explorable 606 | |> Set.toList 607 | |> List.filterMap (\pt -> model |> entityAt pt) 608 | |> List.map (Entity.imaginary) 609 | 610 | -- todo try to optimize further -- almost 10% of our time is spent here :/ 611 | listRememberedEntities : Model -> List Entity 612 | listRememberedEntities model = 613 | model.illuminated 614 | |> Set.diff (viewed model) 615 | |> Set.toList 616 | |> List.filterMap (\pt -> model |> entityAt pt) 617 | |> List.map (Entity.memory) 618 | 619 | listEntities : Model -> List Entity 620 | listEntities model = 621 | let 622 | litEntities = 623 | model.illuminated 624 | |> Set.toList 625 | |> List.filterMap (\pt -> model |> entityAt pt) 626 | 627 | memoryEntities = 628 | model 629 | |> listRememberedEntities 630 | 631 | in 632 | memoryEntities ++ 633 | listInvisibleEntities model ++ 634 | litEntities ++ 635 | [Entity.player model.player] 636 | 637 | view : Model -> List (Svg.Svg a) 638 | view model = 639 | let 640 | entities = 641 | listEntities model 642 | ++ model.animateEntities 643 | 644 | entityViews = 645 | List.map (Entity.view) entities 646 | 647 | highlight = 648 | highlightCells model.debugPath 649 | in 650 | entityViews 651 | ++ highlight 652 | 653 | highlightCells : List Point -> List (Svg.Svg a) 654 | highlightCells cells = 655 | let 656 | pathColor = 657 | Palette.tertiary' 2 0.7 658 | targetColor = 659 | Palette.tertiary' 0 0.7 660 | in 661 | 662 | case cells of 663 | [] -> [] 664 | [x] -> [highlightCell x targetColor] 665 | a :: b :: _ -> 666 | let 667 | tail = 668 | case (List.tail cells) of 669 | Nothing -> [] 670 | Just rest -> highlightCells rest 671 | in 672 | (highlightCell a pathColor) :: tail 673 | 674 | highlightCell (x,y) color = 675 | Graphics.render "@" (x,y) color 676 | -------------------------------------------------------------------------------- /Level.elm: -------------------------------------------------------------------------------- 1 | module Level exposing (Level, init, fromRooms, finalize, moveCreatures, injureCreature, purge, collectCoin, isCoin, isEntrance, isCreature, creatureAt, entityAt, playerSees, itemAt, removeItem, crystalLocation, extrude, evolveGrass, viewFrontier, addItem, hitCreatureWith) 2 | 3 | 4 | import Point exposing (Point) 5 | import Direction exposing (Direction(..)) 6 | import Room exposing (Room, Purpose(..)) 7 | import Graph exposing (Graph) 8 | import Util 9 | import Path 10 | import Configuration 11 | import Weapon exposing (Weapon) 12 | import Armor exposing (Armor) 13 | import Helm exposing (Helm) 14 | import Ring exposing (Ring) 15 | import Warrior 16 | import Creature 17 | import Species 18 | import Liquid 19 | import Spell 20 | import ChallengeRating 21 | import Event exposing (Event) 22 | import Entity exposing (Entity) 23 | import Item exposing (Item) 24 | import Set exposing (Set) 25 | 26 | -- TYPE 27 | 28 | type alias Level = { walls : Set Point 29 | , floors : Set Point 30 | , doors : Set Point 31 | , coins : Set Point 32 | , grass : Set Point 33 | 34 | , creatures : List Creature.Model 35 | 36 | , downstairs : Maybe Point 37 | , upstairs : Maybe Point 38 | , entrance : Maybe (Point, Bool) 39 | 40 | , items : List Item 41 | 42 | , rooms : List Room 43 | 44 | , viewed : Set Point 45 | } 46 | 47 | -- INIT 48 | 49 | init : Level 50 | init = 51 | { walls = Set.empty 52 | , floors = Set.empty 53 | , doors = Set.empty 54 | , coins = Set.empty 55 | , grass = Set.empty 56 | , creatures = [] --Set.empty 57 | , upstairs = Nothing 58 | , downstairs = Nothing 59 | , entrance = Nothing 60 | , rooms = [] 61 | , items = [] 62 | , viewed = Set.empty 63 | } 64 | 65 | finalize : Int -> Level -> Level 66 | finalize depth model = 67 | model 68 | |> finalizeEntrance depth 69 | |> finalizeCrystal depth 70 | |> furnishRooms depth 71 | |> spawnCreatures depth 72 | 73 | finalizeEntrance depth model = 74 | if depth == 0 then 75 | case model.upstairs of 76 | Nothing -> model 77 | Just pt -> 78 | model 79 | |> emplaceEntrance pt 80 | else 81 | model 82 | 83 | finalizeCrystal depth model = 84 | if depth == (Configuration.levelCount - 1) then 85 | case model.downstairs of 86 | Nothing -> model 87 | Just pt -> 88 | model 89 | |> emplaceCrystal pt 90 | else 91 | model 92 | 93 | origin = (0,0) 94 | 95 | -- QUERY 96 | 97 | isWall : Point -> Level -> Bool 98 | isWall pt model = 99 | Set.member pt model.walls 100 | 101 | isCoin : Point -> Level -> Bool 102 | isCoin pt model = 103 | Set.member pt model.coins 104 | 105 | isCreature : Point -> Level -> Bool 106 | isCreature pt model = 107 | List.member pt (List.map .position model.creatures) 108 | 109 | isDoor : Point -> Level -> Bool 110 | isDoor pt model = 111 | Set.member pt model.doors 112 | 113 | isFloor : Point -> Level -> Bool 114 | isFloor pt model = 115 | Set.member pt model.floors 116 | 117 | isGrass : Point -> Level -> Bool 118 | isGrass pt model = 119 | Set.member pt model.grass 120 | 121 | isStairsUp : Point -> Level -> Bool 122 | isStairsUp position model = 123 | case model.upstairs of 124 | Just pt -> 125 | position == pt 126 | Nothing -> 127 | False 128 | 129 | isStairsDown : Point -> Level -> Bool 130 | isStairsDown position model = 131 | case model.downstairs of 132 | Just pt -> 133 | position == pt 134 | Nothing -> 135 | False 136 | 137 | isEntrance : Point -> Level -> Bool 138 | isEntrance position model = 139 | case model.entrance of 140 | Just (pt,_) -> 141 | position == pt 142 | Nothing -> 143 | False 144 | 145 | hasBeenViewed : Point -> Level -> Bool 146 | hasBeenViewed point model = 147 | Set.member point model.viewed 148 | 149 | isAlive livingThing = 150 | livingThing.hp > 0 151 | 152 | entityAt : Point -> Level -> Maybe Entity 153 | entityAt pt model = 154 | case model |> creatureAt pt of 155 | Just creature -> 156 | Just (Entity.monster creature) 157 | 158 | Nothing -> 159 | model 160 | |> nonCreatureEntityAt pt 161 | 162 | 163 | nonCreatureEntityAt : Point -> Level -> Maybe Entity 164 | nonCreatureEntityAt point model = 165 | let 166 | door = 167 | if isDoor point model then 168 | Just (Entity.door point) 169 | else 170 | Nothing 171 | 172 | wall = 173 | if isWall point model then 174 | Just (Entity.wall point) 175 | else 176 | Nothing 177 | 178 | floor = 179 | if isFloor point model then 180 | Just (Entity.floor point) 181 | else 182 | Nothing 183 | 184 | grass = 185 | if isGrass point model then 186 | Just (Entity.grass point) 187 | else 188 | Nothing 189 | 190 | coin = 191 | if isCoin point model then 192 | Just (Entity.coin point) 193 | else 194 | Nothing 195 | 196 | downstairs = 197 | if isStairsDown point model then 198 | Just (Entity.downstairs point) 199 | else 200 | Nothing 201 | 202 | upstairs = 203 | if isStairsUp point model then 204 | Just (Entity.upstairs point) 205 | else 206 | Nothing 207 | 208 | entrance = 209 | if isEntrance point model then 210 | case model.entrance of 211 | Nothing -> 212 | Nothing 213 | Just (pt,open) -> 214 | Just (Entity.entrance open point) 215 | else 216 | Nothing 217 | 218 | item = 219 | case itemAt point model of 220 | Just item' -> 221 | Just (Entity.item item') 222 | 223 | Nothing -> 224 | Nothing 225 | 226 | entities = 227 | [ floor 228 | , grass 229 | , door 230 | , wall 231 | , downstairs 232 | , upstairs 233 | , entrance 234 | , item 235 | , coin 236 | --, monster 237 | ] 238 | in 239 | entities 240 | |> List.filterMap identity 241 | |> List.reverse 242 | |> List.head 243 | 244 | creatureAt : Point -> Level -> Maybe Creature.Model 245 | creatureAt pt model = 246 | model.creatures 247 | |> Util.dropWhile (\c -> not (c.position == pt)) 248 | |> List.head 249 | 250 | itemAt : Point -> Level -> Maybe Item 251 | itemAt pt model = 252 | model.items 253 | |> List.filter (\item -> pt == (item.position)) 254 | |> List.head 255 | 256 | crystalLocation : Level -> Maybe Point 257 | crystalLocation model = 258 | model.items 259 | |> List.filter (\{kind} -> kind == Item.crystal) 260 | |> List.map .position 261 | |> List.head 262 | 263 | viewFrontier : Level -> Set Point 264 | viewFrontier model = 265 | let 266 | {viewed, walls, floors} = 267 | model 268 | 269 | explored = 270 | viewed 271 | |> Set.intersect floors 272 | 273 | unexplored = 274 | viewed 275 | |> Set.diff (Set.union floors walls) 276 | 277 | in 278 | model 279 | |> detectFrontier explored unexplored 280 | 281 | detectFrontier explored unexplored model = 282 | unexplored 283 | |> Set.toList 284 | |> List.concatMap Point.adjacent 285 | |> Set.fromList 286 | --|> Set.diff unexplored ?? 287 | |> Set.intersect explored 288 | 289 | -- HELPERS (for update) 290 | 291 | playerSees : Set Point -> Level -> Level 292 | playerSees pts model = 293 | let 294 | viewed' = 295 | (model.viewed) 296 | |> Set.union (pts) -- |> Set.fromList) 297 | --|> Set.toList 298 | in 299 | { model | viewed = viewed' } 300 | 301 | moveCreatures : Warrior.Model -> Level -> (Level, List Event, Warrior.Model) 302 | moveCreatures player model = 303 | model.creatures 304 | |> List.foldl creatureSteps (model, [], player) 305 | 306 | creatureSteps : Creature.Model -> (Level, List Event, Warrior.Model) -> (Level, List Event, Warrior.Model) 307 | creatureSteps creature (model, events, player) = 308 | let distance = Point.distance player.position creature.position in 309 | if distance < 5 || creature.engaged then 310 | (model |> creatureEngages player creature, events, player) 311 | |> stepCreature creature 312 | else 313 | (model, events, player) 314 | 315 | stepCreature : Creature.Model -> (Level, List Event, Warrior.Model) -> (Level, List Event, Warrior.Model) 316 | stepCreature creature (model, events, player) = 317 | ((model |> creatureMoves creature player), events, player) 318 | |> creatureAttacks creature 319 | 320 | canCreatureStep creature player model = 321 | let 322 | next = 323 | creature.position 324 | |> Point.slide creature.direction 325 | 326 | isPlayer = 327 | player.position == next 328 | 329 | blocked = 330 | isPlayer || 331 | (model |> isWall next) || 332 | (model |> isCreature next) 333 | in 334 | not blocked 335 | 336 | creatureEngages : Warrior.Model -> Creature.Model -> Level -> Level 337 | creatureEngages warrior creature model = 338 | let 339 | creatures' = 340 | model.creatures 341 | |> List.map (\c -> 342 | if c.id == creature.id then 343 | c 344 | |> Creature.engage 345 | |> Creature.turn 346 | ((Point.towards c.position warrior.position) 347 | |> Direction.invert) 348 | else c 349 | ) 350 | in 351 | { model | creatures = creatures' } 352 | 353 | creatureMoves : Creature.Model -> Warrior.Model -> Level -> Level 354 | creatureMoves creature player model = 355 | let 356 | creatures' = 357 | model.creatures 358 | |> List.map (\c -> 359 | if c.id == creature.id && (model |> canCreatureStep c player) then 360 | c |> Creature.step 361 | else c) 362 | in 363 | { model | creatures = creatures' } 364 | 365 | creatureAttacks : Creature.Model -> (Level, List Event, Warrior.Model) -> (Level, List Event, Warrior.Model) 366 | creatureAttacks creature (model, events, player) = 367 | let 368 | pos = 369 | creature.position 370 | |> Point.slide creature.direction 371 | 372 | dmg = 373 | max 1 (creature.attack - (Warrior.resistance player)) 374 | in 375 | if pos == player.position then 376 | (model, events, player) 377 | |> playerTakesDamage creature dmg 378 | |> playerDies ("killed by " ++ (Creature.describe creature)) 379 | else 380 | (model, events, player) 381 | 382 | playerTakesDamage creature amount (model, events, player) = 383 | let 384 | player' = 385 | (Warrior.takeDamage amount player) 386 | 387 | event = 388 | Event.defend creature amount 389 | in 390 | (model, event :: events, player') 391 | 392 | playerDies cause (model, events, player) = 393 | if not (isAlive player) && not (List.any Event.isPlayerDeath events) then 394 | let event = Event.death cause in 395 | (model, event :: events, player) 396 | else 397 | (model, events, player) 398 | 399 | injureCreature : Creature.Model -> Int -> Level -> Level 400 | injureCreature creature amount model = 401 | let 402 | injure = \creature' -> 403 | creature' 404 | |> Creature.injure amount 405 | |> Creature.engage 406 | in 407 | alterCreature injure creature model 408 | 409 | hitCreatureWith : Item -> Creature.Model -> Level -> Level 410 | hitCreatureWith item creature model = 411 | let 412 | damage = 413 | Item.thrownDamage item 414 | in 415 | model 416 | |> injureCreature creature damage 417 | 418 | alterCreature : (Creature.Model -> Creature.Model) -> Creature.Model -> Level -> Level 419 | alterCreature alter creature model = 420 | let 421 | alter' = \c -> 422 | if c.id == creature.id then 423 | alter c 424 | else 425 | c 426 | 427 | creatures' = 428 | model.creatures 429 | |> List.map alter' 430 | in 431 | { model | creatures = creatures' } 432 | 433 | 434 | purge : Level -> (Level, List Event) 435 | purge model = 436 | let 437 | survivors = 438 | List.filter isAlive model.creatures 439 | 440 | killed = 441 | List.filter (not << isAlive) model.creatures 442 | 443 | deathEvents = 444 | List.map Event.killEnemy killed 445 | in 446 | ({ model | creatures = survivors }, deathEvents) 447 | 448 | 449 | collectCoin : Point -> Level -> Level 450 | collectCoin pt model = 451 | let 452 | coins' = 453 | model.coins |> Set.remove pt 454 | in 455 | { model | coins = coins' } 456 | 457 | removeItem : Item -> Level -> Level 458 | removeItem item model = 459 | let 460 | items' = 461 | model.items 462 | |> List.filter (\it -> not (it == item)) 463 | in 464 | { model | items = items' } 465 | 466 | -- GENERATE 467 | 468 | fromRooms : List Room -> Level 469 | fromRooms roomCandidates = 470 | let 471 | rooms = 472 | roomCandidates 473 | |> Room.filterOverlaps 474 | in 475 | init 476 | |> connectRooms rooms 477 | |> extrudeStairwells 478 | |> dropCoins 479 | |> growGrass 480 | 481 | extrudeRooms : Level -> Level 482 | extrudeRooms model = 483 | model.rooms 484 | |> List.foldr extrudeRoom model 485 | 486 | extrudeRoom : Room -> Level -> Level 487 | extrudeRoom room model = 488 | let 489 | (walls,floors) = 490 | Room.layout room 491 | in 492 | { model | walls = Set.union model.walls walls 493 | , floors = Set.union model.floors floors } 494 | 495 | connectRooms : List Room -> Level -> Level 496 | connectRooms rooms model = 497 | let 498 | maybeNetwork = 499 | Room.network rooms 500 | in 501 | case maybeNetwork of 502 | Just graph -> 503 | let 504 | model' = 505 | ({ model | rooms = Graph.listNodes graph } 506 | |> extrudeRooms) 507 | in 508 | graph 509 | |> Graph.fold connectRooms' model' 510 | 511 | Nothing -> 512 | model 513 | 514 | connectRooms' : (Room,Room) -> Level -> Level 515 | connectRooms' (a, b) model = 516 | let 517 | corridor = 518 | Room.corridor a b 519 | in 520 | case corridor of 521 | [] -> model 522 | [pt] -> 523 | model 524 | |> emplaceDoor pt 525 | _ -> 526 | if List.length corridor > 2 then 527 | model 528 | |> extrudeCorridor corridor 529 | |> emplaceDoor (corridor |> List.head |> Maybe.withDefault origin) 530 | |> emplaceDoor (corridor |> List.reverse |> List.head |> Maybe.withDefault origin) 531 | else 532 | model 533 | |> extrudeCorridor corridor 534 | 535 | extrudeCorridor : List Point -> Level -> Level 536 | extrudeCorridor pts model = 537 | pts 538 | |> List.foldr extrude model 539 | 540 | extrude pt model = 541 | model 542 | |> addFloor pt 543 | |> addWallsAround pt 544 | |> removeWall pt 545 | 546 | emplaceDoor : Point -> Level -> Level 547 | emplaceDoor pt model = 548 | { model | doors = Set.insert pt model.doors } 549 | |> addFloor pt 550 | |> removeWall pt 551 | 552 | extrudeStairwells : Level -> Level 553 | extrudeStairwells model = 554 | let 555 | adjacentToFloor = (\pt -> 556 | (Direction.cardinalDirections 557 | |> List.map (\direction -> Point.slide direction pt) 558 | |> List.filter (\pt' -> Set.member pt' (model.floors)) 559 | |> List.length) == 1 560 | ) 561 | 562 | adjacentToTwoWalls = (\pt -> 563 | ([[ North, South ], [ East, West ]] 564 | |> List.map (\ds -> 565 | ds 566 | |> List.map (\d -> Point.slide d pt) 567 | |> List.filter (\pt -> (model |> isWall pt)) 568 | ) 569 | |> List.filter (\ls -> List.length ls > 0) 570 | |> List.length) == 1 571 | ) 572 | 573 | candidates = 574 | model.walls 575 | |> Set.filter adjacentToFloor 576 | |> Set.filter adjacentToTwoWalls 577 | |> Set.toList 578 | 579 | (up, down) = 580 | candidates 581 | |> List.map2 (,) (List.reverse candidates) 582 | |> List.filter (\(a,b) -> not (a == b)) 583 | |> List.sortBy (\(a,b) -> Point.distance a b) 584 | |> List.reverse 585 | |> List.head 586 | |> Maybe.withDefault (origin, origin) 587 | in 588 | model 589 | |> emplaceUpstairs up 590 | |> emplaceDownstairs down 591 | 592 | emplaceUpstairs : Point -> Level -> Level 593 | emplaceUpstairs point model = 594 | { model | upstairs = Just point } 595 | |> addWallsAround point 596 | |> removeWall point 597 | 598 | emplaceDownstairs : Point -> Level -> Level 599 | emplaceDownstairs point model = 600 | { model | downstairs = Just point } 601 | |> addWallsAround point 602 | |> removeWall point 603 | 604 | emplaceCrystal : Point -> Level -> Level 605 | emplaceCrystal point model = 606 | let crystal = Item.init point Item.crystal -1 in 607 | { model | items = model.items ++ [ crystal ] 608 | , downstairs = Nothing 609 | } 610 | |> addWallsAround point 611 | |> removeWall point 612 | |> addFloor point 613 | 614 | emplaceEntrance : Point -> Level -> Level 615 | emplaceEntrance point model = 616 | { model | entrance = Just (point, False) 617 | , upstairs = Nothing 618 | } 619 | |> addWallsAround point 620 | |> removeWall point 621 | 622 | removeWall pt model = 623 | { model | walls = Set.remove pt model.walls } 624 | 625 | removeFloor pt model = 626 | { model | floors = Set.remove pt model.floors } 627 | 628 | addFloor pt model = 629 | { model | floors = Set.insert pt model.floors } 630 | 631 | addWallsAround pt model = 632 | let 633 | newWalls = 634 | Direction.directions 635 | |> List.map (\d -> Point.slide d pt) 636 | |> Set.fromList 637 | |> Set.filter (\wall -> not ( (model |> isFloor wall) || (model |> isDoor wall))) 638 | in 639 | { model | walls = Set.union newWalls model.walls } 640 | 641 | dropCoins : Level -> Level 642 | dropCoins model = 643 | let 644 | path' = 645 | model 646 | |> bestPath 647 | |> List.tail |> Maybe.withDefault [] 648 | |> List.reverse 649 | |> List.tail |> Maybe.withDefault [] 650 | 651 | coins' = 652 | path' 653 | |> Util.everyNth 8 654 | |> List.filter (\pt -> not (isDoor pt model)) 655 | |> Set.fromList 656 | in 657 | { model | coins = coins' } 658 | 659 | furnishRooms : Int -> Level -> Level 660 | furnishRooms depth model = 661 | let model' = model |> assignRooms depth in 662 | model'.rooms 663 | |> List.foldr (furnishRoom depth) model' 664 | 665 | assignRooms : Int -> Level -> Level 666 | assignRooms depth model = 667 | let 668 | rooms' = 669 | model.rooms 670 | |> Util.mapEveryNth 3 (Room.assign Room.library) 671 | |> Util.mapEveryNth 4 (Room.assign Room.barracks) 672 | |> Util.mapEveryNth 5 (Room.assign Room.armory) 673 | |> Util.mapEveryNth 6 (Room.assign Room.miningCamp) 674 | |> List.indexedMap (\id room -> { room | id = id }) 675 | in 676 | { model | rooms = rooms' } 677 | 678 | furnishRoom : Int -> Room -> Level -> Level 679 | furnishRoom depth room model = 680 | case room.purpose of 681 | Nothing -> 682 | model 683 | 684 | Just purpose -> 685 | model 686 | |> furnishRoomFor purpose room depth 687 | 688 | furnishRoomFor : Purpose -> Room -> Int -> Level -> Level 689 | furnishRoomFor purpose room depth model = 690 | let 691 | itemKinds = 692 | case purpose of 693 | Armory -> 694 | [ Item.javelin 695 | , Item.helm Helm.cap 696 | , Item.scroll Spell.infuse 697 | , Item.bottle Liquid.water 698 | , Item.weapon Weapon.dagger 699 | , Item.armor Armor.suit 700 | , Item.weapon Weapon.whip 701 | ] 702 | 703 | Barracks -> 704 | [ Item.javelin 705 | , Item.helm Helm.helmet 706 | , Item.scroll Spell.infuse 707 | , Item.weapon Weapon.sword 708 | , Item.bottle Liquid.water 709 | , Item.weapon Weapon.axe 710 | , Item.scroll Spell.lux 711 | , Item.armor Armor.plate 712 | ] 713 | 714 | Library -> 715 | [ Item.javelin 716 | , Item.ring Ring.light 717 | , Item.scroll Spell.infuse 718 | , Item.bottle Liquid.water 719 | , Item.scroll Spell.lux 720 | , Item.armor Armor.tunic 721 | , Item.bottle Liquid.lifePotion 722 | ] 723 | 724 | MiningCamp -> 725 | [ Item.javelin 726 | , Item.ring Ring.power 727 | , Item.weapon Weapon.pick 728 | , Item.bottle Liquid.water 729 | , Item.scroll Spell.lux 730 | , Item.bottle Liquid.lifePotion 731 | , Item.weapon Weapon.whip 732 | ] 733 | idRange = 734 | [(depth*10000)+(room.id*100)..(depth)*10000+((room.id+1)*100)] 735 | 736 | items = 737 | List.map3 (\pt idx kind -> Item.init pt kind idx) targets idRange itemKinds 738 | 739 | (_,floors') = 740 | Room.layout room 741 | 742 | targets = 743 | floors' 744 | |> Set.toList 745 | |> Util.everyNth 17 746 | in 747 | furnishRoomWith items room model 748 | 749 | furnishRoomWith : List Item -> Room -> Level -> Level 750 | furnishRoomWith items room model = 751 | items 752 | |> List.foldr (furnishRoomWith' room) model 753 | 754 | furnishRoomWith' : Room -> Item -> Level -> Level 755 | furnishRoomWith' room item model = 756 | model |> addItem item 757 | 758 | addItem : Item -> Level -> Level 759 | addItem item model = 760 | { model | items = item :: model.items } 761 | 762 | spawnCreatures : Int -> Level -> Level 763 | spawnCreatures depth model = 764 | model.rooms 765 | |> List.foldr (spawnCreaturesForRoom depth) model 766 | 767 | spawnCreaturesForRoom : Int -> Room -> Level -> Level 768 | spawnCreaturesForRoom depth room model = 769 | let 770 | species = 771 | Species.level (ChallengeRating.forDepth depth) 772 | 773 | (_,floors) = 774 | Room.layout room 775 | 776 | spawnTargets = 777 | floors 778 | |> Set.toList 779 | |> Util.everyNth 9 780 | 781 | creatureCount = 782 | 1 + (List.length (model.creatures)) 783 | 784 | spawnCount = 785 | 1 + (creatureCount % 5) 786 | 787 | creatures' = 788 | spawnTargets 789 | |> List.map3 (\species n pt -> Creature.init species n pt) species [(creatureCount)..(creatureCount+spawnCount)] 790 | in 791 | { model | creatures = model.creatures ++ creatures' } 792 | 793 | bestPath : Level -> List Point 794 | bestPath model = 795 | let 796 | down = 797 | case model.downstairs of 798 | Just pt -> 799 | pt 800 | 801 | Nothing -> 802 | case (crystalLocation model) of 803 | Just pt -> 804 | pt 805 | 806 | Nothing -> 807 | origin 808 | 809 | up = 810 | case model.upstairs of 811 | Just pt -> 812 | pt 813 | Nothing -> 814 | case model.entrance of 815 | Just (pt,_) -> 816 | pt 817 | Nothing -> 818 | origin 819 | in 820 | Path.seek up down (\pt -> isWall pt model) 821 | 822 | growGrass : Level -> Level 823 | growGrass model = 824 | let 825 | {floors, walls} = 826 | model 827 | 828 | seeds = 829 | floors 830 | |> Set.toList 831 | |> Util.filterChamp 832 | in 833 | seeds 834 | |> List.foldr seedGrassAt model 835 | |> evolveGrass 25 836 | 837 | seedGrassAt : Point -> Level -> Level 838 | seedGrassAt pt model = 839 | let 840 | grass' = 841 | Set.insert pt model.grass 842 | in 843 | { model | grass = grass' } 844 | 845 | removeGrassAt : Point -> Level -> Level 846 | removeGrassAt pt model = 847 | let 848 | grass' = 849 | Set.remove pt model.grass 850 | in 851 | { model | grass = grass' } 852 | 853 | evolveGrass : Int -> Level -> Level 854 | evolveGrass n model = 855 | if n < 0 then 856 | model 857 | else 858 | let 859 | (add,remove) = 860 | model.floors 861 | |> Set.toList 862 | |> List.foldr (evolveGrassAt model) ([],[]) 863 | 864 | model' = 865 | (add |> List.foldr seedGrassAt model) 866 | in 867 | (remove |> List.foldr removeGrassAt model') 868 | 869 | evolveGrassAt model pt (add,remove) = 870 | let 871 | neighbors = 872 | Direction.directions 873 | |> List.map (\dir -> Point.slide dir pt) 874 | |> List.filter (\pt -> model |> isGrass pt) 875 | |> List.length 876 | 877 | alive = 878 | Set.member pt model.grass 879 | in 880 | if alive then 881 | if neighbors < 3 || 5 < neighbors then 882 | (add, pt :: remove) 883 | else 884 | (add, remove) 885 | else if neighbors > 2 && 6 > neighbors then 886 | (pt :: add, remove) 887 | else 888 | (add, remove) 889 | -------------------------------------------------------------------------------- /Engine.elm: -------------------------------------------------------------------------------- 1 | module Engine exposing (Engine, init, view, enter, speak, clickAt, hoverAt, tick, handleKeypress, resetHover, autorogue) 2 | 3 | import Point exposing (Point, slide) 4 | import Direction exposing (Direction(..)) 5 | import Path 6 | import World 7 | import Dungeon exposing (Dungeon) 8 | import Entity exposing (Entity) 9 | import Configuration 10 | import Util 11 | import Graphics 12 | import Warrior 13 | import Quest exposing (Quest) 14 | import Journal 15 | import Log 16 | import Status 17 | import Item exposing (Item, ItemKind(..)) 18 | import Spell exposing (Spell(..)) 19 | import Action exposing (Action(..)) 20 | import Palette 21 | import Inventory 22 | import Optics 23 | import Language exposing (Language) 24 | 25 | import Level 26 | 27 | import Set exposing (Set) 28 | import Time 29 | import Mouse 30 | import Svg exposing (svg, rect, text') 31 | import Svg.Attributes exposing (viewBox, width, height, x, y, fontSize, fontFamily) 32 | import Svg.Events 33 | 34 | type alias Engine = 35 | { world : World.Model 36 | , hover : Maybe Entity 37 | , hoverPath : List Point 38 | , followPath : Maybe (List Point) 39 | , auto : Bool 40 | , telepathy : Bool 41 | , quests : List Quest 42 | , action : Maybe Action 43 | , selectPosition : Bool 44 | , throwPath : Maybe (List Point) 45 | , animatingThrow : Bool 46 | , thrownItem : Maybe Item 47 | } 48 | 49 | init : Engine 50 | init = 51 | { world = World.init 52 | , hover = Nothing 53 | , hoverPath = [] 54 | , followPath = Nothing 55 | , auto = False 56 | , telepathy = False 57 | , quests = Quest.coreCampaign 58 | , action = Nothing 59 | , selectPosition = False 60 | , throwPath = Nothing 61 | , animatingThrow = False 62 | , thrownItem = Nothing 63 | } 64 | 65 | isPerformingAnimation : Engine -> Bool 66 | isPerformingAnimation model = 67 | model.animatingThrow 68 | 69 | enter : Dungeon -> Engine -> Engine 70 | enter dungeon model = 71 | let 72 | dungeon' = 73 | dungeon |> Dungeon.prepare Configuration.levelCount 74 | 75 | world = 76 | model.world 77 | 78 | player = 79 | world.player 80 | 81 | startPos = 82 | case (Dungeon.levelAt 0 dungeon').entrance of 83 | Just (pt,_) -> pt 84 | Nothing -> (10,10) 85 | 86 | player' = 87 | { player | position = startPos } 88 | 89 | world' = 90 | { world | dungeon = dungeon' 91 | , depth = 0 92 | , player = player' 93 | } 94 | in 95 | ({ model | world = world' |> World.playerViewsField 96 | }) 97 | 98 | speak : Language -> Engine -> Engine 99 | speak language model = 100 | let 101 | world = 102 | model.world 103 | 104 | world' = 105 | { world | language = language } 106 | 107 | in 108 | { model | world = world' } 109 | 110 | illuminate : Engine -> Engine 111 | illuminate model = 112 | { model | world = World.playerViewsField model.world } 113 | 114 | handleKeypress : Char -> Engine -> Engine 115 | handleKeypress keyChar model = 116 | if model |> isPerformingAnimation then 117 | model -- ignore it until we're done animating 118 | else 119 | let 120 | reset = ( 121 | resetThrow << 122 | resetAction << 123 | resetFollow << 124 | resetAuto << 125 | illuminate << 126 | moveCreatures 127 | ) 128 | in 129 | case model.action of 130 | Just action -> 131 | model |> case keyChar of 132 | 'd' -> 133 | let act' = (if action == Action.drop then Action.default else Action.drop) in 134 | waitForSelection act' 135 | 'i' -> 136 | if action == Action.drop then 137 | waitForSelection Action.default 138 | else 139 | resetAction 140 | _ -> 141 | let alpha = Util.fromAlpha keyChar in 142 | if alpha == -1 then 143 | resetAction 144 | else 145 | playerActs (Util.fromAlpha keyChar) 146 | 147 | Nothing -> 148 | model |> case keyChar of 149 | 'a' -> autorogue 150 | 'h' -> reset << playerSteps West 151 | 'j' -> reset << playerSteps South 152 | 'k' -> reset << playerSteps North 153 | 'l' -> reset << playerSteps East 154 | 't' -> telepath 155 | 'x' -> playerExplores 156 | 'd' -> waitForSelection Action.drop 157 | 'i' -> waitForSelection Action.default 158 | _ -> reset 159 | 160 | waitForSelection : Action -> Engine -> Engine 161 | waitForSelection action model = 162 | { model | action = Just action } 163 | 164 | waitForPosition : Action -> Engine -> Engine 165 | waitForPosition action model = 166 | { model | action = Just action 167 | , selectPosition = True 168 | } 169 | 170 | isEquipped : Item -> Engine -> Bool 171 | isEquipped item model = 172 | let 173 | player = 174 | model.world.player 175 | 176 | isArmor = 177 | case player.armor of 178 | Nothing -> 179 | False 180 | Just armor -> 181 | item == (Item.simple (Item.armor armor)) 182 | 183 | isWeapon = 184 | case player.weapon of 185 | Nothing -> 186 | False 187 | Just weapon -> 188 | item == (Item.simple (Item.weapon weapon)) 189 | 190 | isHelm = 191 | case player.helm of 192 | Nothing -> 193 | False 194 | Just helm -> 195 | item == (Item.simple (Item.helm helm)) 196 | 197 | isRing = 198 | case player.ring of 199 | Nothing -> 200 | False 201 | Just ring -> 202 | item == (Item.simple (Item.ring ring)) 203 | in 204 | isArmor 205 | || isWeapon 206 | || isHelm 207 | || isRing 208 | 209 | playerActs : Int -> Engine -> Engine 210 | playerActs idx model = 211 | let 212 | maybeItem = 213 | model.world.player 214 | |> Inventory.itemAtIndex idx 215 | in 216 | case maybeItem of 217 | Nothing -> 218 | model 219 | |> resetAction 220 | 221 | Just item -> 222 | case model.action of 223 | Nothing -> 224 | model 225 | 226 | Just act -> 227 | if Action.canPerform (isEquipped item model) item act then 228 | model |> playerActsOnItem item act 229 | else 230 | model 231 | 232 | playerActsOnItem : Item -> Action -> Engine -> Engine 233 | playerActsOnItem item act model = 234 | case act of 235 | Drop -> 236 | { model | world = model.world |> World.playerDropsItem item } 237 | 238 | Wear -> 239 | { model | world = model.world |> World.playerWears item } 240 | |> playerLosesItem item 241 | 242 | TakeOff -> 243 | { model | world = model.world |> World.playerTakesOff item } 244 | 245 | Wield -> 246 | { model | world = model.world |> World.playerWields item } 247 | |> playerLosesItem item 248 | 249 | Sheathe -> 250 | { model | world = model.world |> World.playerSheathesWeapon } 251 | 252 | Drink -> 253 | { model | world = model.world |> World.playerDrinks item } 254 | |> playerLosesItem item 255 | 256 | Read -> 257 | case item.kind of 258 | Scroll spell -> 259 | model 260 | |> castSpell item spell 261 | _ -> 262 | model 263 | 264 | Use item' act' -> 265 | -- todo this could be refined? 266 | if Item.canApply item' item then 267 | model 268 | |> playerApplies item' item 269 | |> waitForSelection Action.default 270 | else 271 | model 272 | 273 | Default -> 274 | let 275 | equipped = 276 | isEquipped item model 277 | 278 | action' = 279 | Action.defaultForItem equipped item 280 | in 281 | model 282 | |> playerActsOnItem item action' 283 | 284 | Throw -> 285 | model 286 | |> resetAuto 287 | |> waitForPosition (Action.hurl item) 288 | 289 | Hurl it -> 290 | model 291 | 292 | Identify -> 293 | model 294 | 295 | Look -> 296 | model 297 | 298 | Enchant -> 299 | model 300 | 301 | playerApplies : Item -> Item -> Engine -> Engine 302 | playerApplies item' item model = 303 | case item'.kind of 304 | Scroll spell -> 305 | case spell of 306 | Infuse -> 307 | model 308 | |> playerLosesItem item' 309 | |> playerEnchants item 310 | 311 | Lux -> 312 | model 313 | _ -> 314 | model 315 | 316 | resetAction : Engine -> Engine 317 | resetAction model = 318 | { model | action = Nothing 319 | , selectPosition = False 320 | } 321 | 322 | playerLosesItem : Item -> Engine -> Engine 323 | playerLosesItem item model = 324 | let 325 | world = 326 | model.world 327 | 328 | player = 329 | world.player 330 | 331 | inventory = 332 | player.inventory 333 | 334 | inventory' = 335 | inventory 336 | |> List.filter (\it -> not (it == item)) 337 | 338 | player' = 339 | { player | inventory = inventory' } 340 | in 341 | { model | world = { world | player = player' } } 342 | 343 | castSpell : Item -> Spell -> Engine -> Engine 344 | castSpell item spell model = 345 | let 346 | world' = 347 | model.world 348 | |> World.playerLearnsWord (Language.wordFor (Spell.idea spell) model.world.language) 349 | 350 | model' = 351 | { model | world = world' } 352 | in 353 | case spell of 354 | Lux -> 355 | model' 356 | |> playerLosesItem item 357 | |> enhancePlayerVision 358 | 359 | Infuse -> 360 | model' 361 | |> waitForSelection (Action.use item (Action.enchant)) 362 | 363 | enhancePlayerVision : Engine -> Engine 364 | enhancePlayerVision model = 365 | { model | world = model.world 366 | |> World.augmentVision 367 | |> World.playerViewsField 368 | } 369 | 370 | playerEnchants : Item -> Engine -> Engine 371 | playerEnchants item model = 372 | { model | world = model.world 373 | |> World.enchantItem item 374 | } 375 | 376 | tick : Time.Time -> Engine -> Engine 377 | tick time model = 378 | if model |> isPerformingAnimation then 379 | Debug.log "ANIMATE MODEL" 380 | model 381 | |> animate 382 | else 383 | model 384 | |> followPaths 385 | |> updateQuests 386 | 387 | animate : Engine -> Engine 388 | animate model = 389 | if model.animatingThrow then 390 | model 391 | |> animateThrow 392 | else 393 | Debug.log "animate called but nothing being animated...?" 394 | model 395 | 396 | animateThrow : Engine -> Engine 397 | animateThrow model = 398 | case model.thrownItem of 399 | Nothing -> 400 | Debug.log "no thrown item, reset throw" 401 | model |> resetThrow 402 | 403 | Just item -> 404 | case model.throwPath of 405 | Nothing -> 406 | Debug.log "no throw path, reset throw" 407 | model |> resetThrow 408 | 409 | Just path -> 410 | case path |> List.head of 411 | Nothing -> 412 | Debug.log "throw path empty, reset throw" 413 | model |> resetThrow 414 | 415 | Just pt -> 416 | let 417 | item' = 418 | { item | position = pt } 419 | 420 | model' = 421 | { model | thrownItem = Just item' 422 | , throwPath = List.tail path } 423 | in 424 | if List.length path > 1 then 425 | model' 426 | else 427 | { model' | world = model.world 428 | |> World.hitCreatureAt pt item' --thrownItem 429 | } 430 | 431 | resetThrow : Engine -> Engine 432 | resetThrow model = 433 | let 434 | model' = 435 | { model | throwPath = Nothing -- Just model.hoverPath 436 | , animatingThrow = False 437 | , action = Nothing --Just Action.default 438 | , thrownItem = Nothing 439 | --, auto = True 440 | , selectPosition = False 441 | } 442 | in 443 | case model.thrownItem of 444 | Nothing -> -- but how did we get here? 445 | model' 446 | 447 | Just item -> 448 | Debug.log "ADD ITEM BACK TO DUNGEON" 449 | model' 450 | |> addItem item 451 | 452 | addItem : Item -> Engine -> Engine 453 | addItem item model = 454 | let 455 | world = 456 | model.world 457 | 458 | dungeon = 459 | world.dungeon 460 | |> Dungeon.apply (Level.addItem item) world.depth 461 | in 462 | { model | world = { world | dungeon = dungeon }} 463 | 464 | updateQuests : Engine -> Engine 465 | updateQuests model = 466 | let 467 | quests' = 468 | model.quests 469 | |> Quest.unlocked model.world 470 | in 471 | { model | quests = quests' ++ model.quests } 472 | 473 | followPaths : Engine -> Engine 474 | followPaths model = 475 | case model.followPath of 476 | Nothing -> 477 | if model.auto then 478 | model 479 | |> playerExplores 480 | else 481 | model 482 | 483 | Just path -> 484 | model 485 | |> playerFollowsPath 486 | 487 | autorogue model = 488 | { model | auto = True } 489 | 490 | telepath model = 491 | if model.telepathy then 492 | { model | telepathy = False } 493 | else 494 | { model | telepathy = True } 495 | 496 | moveCreatures model = 497 | let 498 | world = 499 | model.world 500 | 501 | (dungeon', events, player') = 502 | world.dungeon 503 | |> Dungeon.moveCreatures world.player world.depth 504 | 505 | world' = 506 | { world | dungeon = dungeon' 507 | , events = world.events ++ List.reverse events 508 | , player = player' 509 | } 510 | 511 | in 512 | { model | world = world' } 513 | 514 | playerSteps direction model = 515 | { model | world = model.world |> World.playerSteps direction } 516 | 517 | resetHover : Engine -> Engine 518 | resetHover model = 519 | { model | hoverPath = [] 520 | , hover = Nothing } 521 | 522 | resetFollow : Engine -> Engine 523 | resetFollow model = 524 | { model | followPath = Nothing } 525 | 526 | resetAuto : Engine -> Engine 527 | resetAuto model = 528 | { model | auto = False } 529 | 530 | 531 | hoverAt : Point -> Engine -> Engine 532 | hoverAt pt model = 533 | let 534 | point = 535 | pt 536 | --pointFromMouse position 537 | 538 | isLit = 539 | Set.member point (model.world.illuminated) 540 | 541 | wasLit = 542 | Set.member point (World.viewed model.world) 543 | in 544 | if model.selectPosition then 545 | model |> targetEntityAt point 546 | else 547 | if isLit then 548 | model |> seeEntityAt point 549 | else 550 | if wasLit then 551 | model |> rememberEntityAt point 552 | else 553 | if model.telepathy then 554 | model |> imagineEntityAt point 555 | else 556 | model 557 | 558 | targetEntityAt point model = 559 | let 560 | entity' = 561 | World.entityAt point model.world 562 | 563 | entity = 564 | if entity' == Just (Entity.wall point) then 565 | Nothing 566 | else 567 | entity' 568 | 569 | path' = 570 | case entity of 571 | Nothing -> 572 | [] 573 | 574 | Just entity' -> 575 | model 576 | |> lineToEntity entity' 577 | in 578 | { model | hover = entity 579 | , hoverPath = path' 580 | } 581 | 582 | seeEntityAt point model = 583 | let 584 | entity = 585 | World.entityAt point model.world 586 | 587 | path' = 588 | case entity of 589 | Nothing -> 590 | [] 591 | 592 | Just entity' -> 593 | model |> pathToEntity entity' 594 | 595 | in 596 | { model | hover = entity 597 | , hoverPath = path' 598 | } 599 | 600 | rememberEntityAt point model = 601 | let 602 | entity = 603 | World.entityAt point model.world 604 | 605 | maybeEntity = 606 | case entity of 607 | Just entity' -> 608 | if (Entity.isCreature entity') then 609 | Nothing 610 | else 611 | Just (Entity.memory entity') 612 | Nothing -> 613 | Nothing 614 | 615 | path' = 616 | case maybeEntity of 617 | Nothing -> 618 | [] 619 | 620 | Just entity -> 621 | model |> pathToEntity entity 622 | in 623 | { model | hover = maybeEntity 624 | , hoverPath = path' 625 | } 626 | 627 | 628 | imagineEntityAt point model = 629 | let 630 | entity = 631 | World.entityAt point model.world 632 | 633 | maybeEntity = 634 | case entity of 635 | Just entity' -> 636 | Just (Entity.imaginary entity') 637 | Nothing -> 638 | Nothing 639 | 640 | path' = 641 | case maybeEntity of 642 | Nothing -> 643 | [] 644 | 645 | Just entity -> 646 | model |> pathToEntity entity 647 | in 648 | { model | hover = maybeEntity 649 | , hoverPath = path' 650 | } 651 | 652 | pathToEntity entity model = 653 | let 654 | entityPos = 655 | Entity.position entity 656 | 657 | playerPos = 658 | model.world.player.position 659 | 660 | alreadyHovering = 661 | case model.hover of 662 | Just entity' -> 663 | entity' == entity 664 | Nothing -> False 665 | 666 | in 667 | if alreadyHovering || not (model.followPath == Nothing) then 668 | model.hoverPath 669 | else 670 | Path.seek entityPos playerPos (\pt -> Set.member pt (World.walls model.world)) 671 | 672 | 673 | lineToEntity entity model = 674 | let 675 | entityPos = 676 | Entity.position entity 677 | 678 | playerPos = 679 | model.world.player.position 680 | 681 | alreadyHovering = 682 | case model.hover of 683 | Just entity' -> 684 | entity' == entity 685 | 686 | Nothing -> 687 | False 688 | in 689 | if alreadyHovering || not (model.throwPath == Nothing) then 690 | model.hoverPath 691 | else 692 | let ray = Optics.castRay (Warrior.vision model.world.player) (World.walls model.world) playerPos entityPos in 693 | ray 694 | |> List.filter (\pt -> not (Set.member pt (World.walls model.world))) 695 | 696 | clickAt : Mouse.Position -> Engine -> Engine 697 | clickAt _ model = 698 | case model.followPath of 699 | Nothing -> 700 | if model.selectPosition then 701 | case model.action of 702 | Just action -> 703 | case action of 704 | Hurl item -> 705 | model 706 | |> throwItem item 707 | 708 | _ -> 709 | Debug.log "clicked for position, but some action was associated besides hurl?" 710 | model 711 | |> waitForSelection Action.default 712 | 713 | Nothing -> 714 | Debug.log "clicked for position, but no action was associated?" 715 | model 716 | |> waitForSelection Action.default 717 | else 718 | { model | followPath = Just model.hoverPath } 719 | 720 | Just path -> 721 | model 722 | 723 | throwItem : Item -> Engine -> Engine 724 | throwItem item model = 725 | Debug.log ("THROW ITEM: " ++ (Item.name item)) 726 | { model | throwPath = Just model.hoverPath 727 | , animatingThrow = True 728 | , selectPosition = False 729 | , thrownItem = Just item 730 | , auto = False 731 | } 732 | --|> resetAuto 733 | 734 | playerFollowsPath : Engine -> Engine 735 | playerFollowsPath model = 736 | case model.followPath of 737 | Nothing -> 738 | model 739 | 740 | Just path -> 741 | case (List.head path) of 742 | Nothing -> 743 | model 744 | |> resetHover 745 | |> resetFollow 746 | 747 | Just nextStep -> 748 | let 749 | playerPos = 750 | model.world.player.position 751 | 752 | direction = 753 | (Point.towards nextStep playerPos) 754 | 755 | onPath = 756 | nextStep == (playerPos |> slide direction) 757 | 758 | followPath' = 759 | List.tail path 760 | in 761 | if onPath then 762 | ({model | followPath = followPath' }) 763 | |> playerSteps direction 764 | |> moveCreatures 765 | |> illuminate 766 | else 767 | model 768 | |> resetFollow 769 | |> resetHover 770 | 771 | gatherTargets : Engine -> List Point 772 | gatherTargets model = 773 | let 774 | viewed = 775 | World.viewed model.world 776 | 777 | explored = 778 | World.floors model.world 779 | |> Set.intersect viewed 780 | 781 | visibleCreatures = 782 | (World.creatures model.world) 783 | |> List.map .position 784 | |> List.filter (\pt -> Set.member pt explored) 785 | 786 | visibleCoins = 787 | (World.coins model.world) 788 | |> List.filter (\pt -> Set.member pt explored) 789 | 790 | visibleItems = 791 | if Inventory.size model.world.player < Configuration.inventoryLimit then 792 | (World.items model.world) 793 | |> List.map .position 794 | |> List.filter (\pt -> Set.member pt explored) 795 | else 796 | [] 797 | in 798 | visibleCreatures ++ visibleItems ++ visibleCoins 799 | 800 | 801 | exploreTargets : Engine -> List Point 802 | exploreTargets model = 803 | if model.world |> World.doesPlayerHaveCrystal then 804 | World.upstairs model.world ++ World.entrances model.world 805 | else 806 | let frontier = World.viewFrontier model.world in 807 | if Set.size frontier == 0 then 808 | World.downstairs model.world ++ World.crystals model.world 809 | else 810 | frontier |> Set.toList 811 | 812 | autorogueDestination : Engine -> Maybe Point 813 | autorogueDestination model = 814 | let 815 | gather = 816 | gatherTargets model 817 | 818 | byDistanceFromPlayer = \pt -> 819 | Point.distance model.world.player.position pt 820 | in 821 | if List.length gather > 0 then 822 | gather 823 | |> List.sortBy byDistanceFromPlayer 824 | |> List.head 825 | else 826 | exploreTargets model 827 | |> List.sortBy byDistanceFromPlayer 828 | |> List.head 829 | 830 | playerExplores : Engine -> Engine 831 | playerExplores model = 832 | let 833 | path = 834 | case autorogueDestination model of 835 | Nothing -> 836 | Nothing 837 | 838 | Just dest -> 839 | let 840 | walls = 841 | World.walls model.world 842 | 843 | blocked = \pt -> 844 | Set.member pt walls 845 | 846 | path' = 847 | Path.seek dest model.world.player.position blocked 848 | in 849 | if List.length path' == 0 then 850 | Nothing 851 | else 852 | Just path' 853 | in 854 | { model | followPath = path } 855 | 856 | -- VIEW 857 | view : Engine -> List (Svg.Svg a) 858 | view model = 859 | let 860 | world = 861 | model.world 862 | 863 | lang = 864 | world.language 865 | 866 | vocab = 867 | world.player.vocabulary 868 | 869 | path = 870 | case model.followPath of 871 | Nothing -> 872 | if model |> isPerformingAnimation then 873 | [] 874 | else 875 | model.hoverPath 876 | 877 | Just path -> 878 | path 879 | 880 | worldView = 881 | World.view { world | debugPath = path 882 | , showMap = model.telepathy 883 | , animateEntities = [ model.thrownItem ] 884 | |> List.filterMap identity 885 | |> List.map Entity.item 886 | } 887 | 888 | debugMsg = 889 | case model.action of 890 | Just action' -> 891 | Action.question vocab lang action' 892 | 893 | Nothing -> 894 | model |> hoverMessage vocab lang 895 | 896 | note = 897 | Graphics.render debugMsg (25,1) Palette.accentLighter 898 | 899 | rightBarY = 900 | Configuration.viewWidth - 15 901 | 902 | quests = 903 | Journal.view (rightBarY,2) model.world model.quests 904 | 905 | character = 906 | model.world.player 907 | |> Warrior.cardView (rightBarY, 5+(List.length model.quests)) (model.action) 908 | 909 | inventory = 910 | Inventory.view (rightBarY, 10+(List.length model.quests)) vocab lang model.action model.world.player 911 | 912 | log = 913 | Log.view (2, (Configuration.viewHeight - 6)) vocab lang model.world.events 914 | 915 | status = 916 | Status.view (1,1) model.world 917 | 918 | rightBar = 919 | quests 920 | ++ character 921 | ++ inventory 922 | 923 | in 924 | worldView 925 | ++ status 926 | ++ [note] 927 | ++ rightBar 928 | ++ log 929 | 930 | hoverMessage : Language -> Language -> Engine -> String 931 | hoverMessage vocab lang model = 932 | case model.hover of 933 | Nothing -> 934 | "You aren't looking at anything in particular." 935 | 936 | Just entity -> 937 | case entity of 938 | Entity.Memory e -> 939 | "You remember seeing " ++ (Entity.describe vocab lang e) ++ " here." 940 | Entity.Imaginary e -> 941 | "You imagine there is " ++ (Entity.describe vocab lang e) ++ " here." 942 | _ -> 943 | "You see " ++ (Entity.describe vocab lang entity) ++ "." 944 | --------------------------------------------------------------------------------