Refactor to hopefully avoid compiler bugs

This commit is contained in:
Aly 2021-03-09 16:01:09 -08:00
parent ffdcfd2789
commit 02f5ff2b20
10 changed files with 770 additions and 139 deletions

1
.gitignore vendored
View file

@ -1 +0,0 @@
main.lua

259
build/oot/main.lua Normal file
View file

@ -0,0 +1,259 @@
do
local function S(a)
return function(b)
return { __tag = "S", a, b }
end
end
local function MkSome(a)
return function(b)
return { __tag = "MkSome", a, b }
end
end
local Proxy = { __tag = "Proxy" }
local function Some(a)
return { __tag = "Some", a }
end
local Nil = { __tag = "Nil" }
local None = { __tag = "None" }
local function _TypeRep(x)
return {
{
name = x.name .. "#" .. x.fingerprint
},
__tag = "TypeRep"
}
end
local function __eq_type_rep(tr_a, tr_b, keq, kne)
if tr_a[1].name == tr_b[1].name then
return keq()()
else
return kne()
end
end
local function _Typeable_app(pair)
local ta, tb = pair._1[1], pair._2[1]
return {
{
name = "(" .. ta.name .. ") :$ (" .. tb.name .. ")"
},
__tag = "TypeRep"
}
end
local string_of_int = tostring
local function _dollardExceptionljv(tmp)
return {
from_exception = function(x)
return Some(x)
end,
["Exception$lae"] = _Typeable_app({
_1 = (function(tmp0)
return _TypeRep({
fingerprint = 271,
name = "some"
})
end)(),
_2 = (function(tmp0)
return _TypeRep({
fingerprint = 276,
name = "exception"
})
end)()
}),
describe_exception = function(tmp0)
return tmp0[1].describe_exception(tmp0[2])
end,
into_exception = function(x)
return x
end
}
end
local function from_exception(mdm, mgf)
local tmp = (function(tmp)
return _TypeRep({
fingerprint = 304,
name = "user_error"
})
end)()
local x = mgf[2]
return __eq_type_rep((function()
return mgf[1]["Exception$lae"]
end)(Proxy), (function()
return tmp
end)(Proxy), function(tmp0)
return function(tmp1) return Some(x) end
end, function(tmp0) return None end)
end
local function from_exception0(mdm)
return function(mgf)
return from_exception(mdm, mgf)
end
end
local function _dollardExceptionmcp(tmp)
return {
describe_exception = function(tmp0)
return "User error: " .. tmp0
end,
["Exception$lae"] = (function(tmp0)
return _TypeRep({
fingerprint = 304,
name = "user_error"
})
end)(),
into_exception = function(mgv)
return MkSome(_dollardExceptionmcp(nil))(mgv)
end,
from_exception = from_exception0(tmp)
}
end
local function _dollarfoldr(ukg)
return function(f)
return function(z)
local function loop(k, x)
if x.__tag ~= "Cons" then
return k(z)
end
local tmp = x[1]
local x0 = tmp._1
return loop(function(r)
return k(f(x0)(r))
end, tmp._2)
end
return function(x)
return loop(function(x0)
return x0
end, x)
end
end
end
end
local _dollardFoldableujg, foldl1, foldl10
_dollardFoldableujg = function(tmp)
return {
foldl1 = foldl1(tmp),
foldr = _dollarfoldr(tmp),
["Foldable$tre"] = function(f)
return function(xs)
local function avi(xss)
if xss.__tag ~= "Cons" then
return Nil
end
local tmp0 = xss[1]
return {
{ _1 = f(tmp0._1), _2 = avi(tmp0._2) },
__tag = "Cons"
}
end
return avi(xs)
end
end,
foldl = function(f)
local function loop(z)
return function(x)
if x.__tag ~= "Cons" then return z end
local tmp0 = x[1]
return loop(f(z)(tmp0._1))(tmp0._2)
end
end
return loop
end
}
end
foldl1 = function(ukg)
return function(uvw)
return function(uvx)
return foldl10(ukg, uvw, uvx)
end
end
end
foldl10 = function(ukg, uvw, uvx)
local tmp = _dollardFoldableujg(nil).foldl(function(m)
return function(y)
if m.__tag == "None" then
return Some(y)
end
return Some(uvw(m[1])(y))
end
end)(None)(uvx)
if tmp.__tag == "None" then
return error(setmetatable(_dollardExceptionmcp(nil).into_exception("foldl1: empty structure"), {
__tostring = _dollardExceptionljv(nil).describe_exception
}))
end
return tmp[1]
end
local io_stdout = io.stdout
local io_stderr = io.stderr
local io_stdin = io.stdin
local read_value_16 = ReadValue16
local set_screen_text = SetScreenText
local function pretty_from_record(agyo, a, w)
local function smul(s, n)
if n <= 0 then return "" end
return s .. smul(s, n - 1)
end
local prep = smul(" ", w)
local rf = agyo.fields(a)
local x = w + 2
return agyo.name(a) .. " {\n" .. _dollardFoldableujg(nil).foldl(function(acc)
return function(f)
local name = f._1
local field = f._2
if field.__tag == "S" then
return acc .. prep .. " " .. (name .. " = " .. field[1](field[2])) .. ",\n"
end
return acc .. prep .. " " .. (name .. " = " .. field[1](field[2])(x)) .. ",\n"
end
end)("")(rf) .. prep .. "}"
end
local function onScriptStart(tmp)
return nil
end
local function onScriptCancel(tmp)
return nil
end
local function onScriptUpdate(tmp)
local u16 = read_value_16(17295140)
local function tmp0(save_ctx)
return set_screen_text(pretty_from_record({
fields = function(tmp0)
return {
{
_2 = Nil,
_1 = {
_1 = "rupees",
_2 = S(function(tmp1)
return string_of_int(tmp1) .. "_s16"
end)(tmp0.rupees)
}
},
__tag = "Cons"
}
end,
name = function(tmp0)
return "SaveContext"
end
}, save_ctx, 0))
end
if u16 > 32767 then
return tmp0({
rupees = 0 - (65536 - u16)
})
end
return tmp0({ rupees = u16 })
end
local function onStateLoaded(tmp)
return nil
end
local function onStateSaved(tmp)
return nil
end
return {
base_address = 16138528,
g_save_ctx_address = 1156560,
onScriptCancel = onScriptCancel,
onScriptStart = onScriptStart,
onScriptUpdate = onScriptUpdate,
onStateLoaded = onStateLoaded,
onStateSaved = onStateSaved
}
end

23
build/ootAI.lua Normal file
View file

@ -0,0 +1,23 @@
package.path = GetScriptsDir() .. "oot/main.lua"
local main = require("main")
function onScriptStart()
main.onScriptStart()
end
function onScriptCancel()
main.onScriptCancel()
end
function onScriptUpdate()
main.onScriptUpdate()
end
function onStateLoaded()
main.onStateLoaded()
end
function onStateSaved()
main.onStateSaved()
end

View file

@ -1,103 +1,12 @@
open import "prelude.ml"
type u8 =
U8 of int
instance show u8 begin
let show (U8 x) = (show x) ^ "_u8"
end
type s8 =
S8 of int
instance show s8 begin
let show (S8 x) =
let signfix =
if x > 127 then
negate (256 - x)
else
x
(show signfix) ^ "_s8"
end
type u16 =
U16 of int
instance show u16 begin
let show (U16 x) = (show x) ^ "_u16"
end
type s16 =
S16 of int
instance show s16 begin
let show (S16 x) =
let signfix =
if x > 32767 then
negate (65536 - x)
else
x
(show signfix) ^ "_s16"
end
type u32 =
U32 of int
type s32 =
S32 of int
instance show s32 begin
let show (S32 x) =
let signfix =
if x > 2147483647 then
negate (4294967296 - x)
else
x
(show signfix) ^ "_s32"
end
module Dolphin = struct
external val read_value_8 : int -> () -> int =
"function(addr, n) return ReadValue8(addr) end"
external val read_value_16 : int -> () -> int =
"function(addr, n) return ReadValue16(addr) end"
external val read_value_32 : int -> () -> int =
"function(addr, n) return ReadValue32(addr) end"
external val read_value_float : int -> () -> float =
"function(addr, n) return ReadValueFloat(addr) end"
external val read_value_string : int -> int -> () -> string =
"function(addr, len, n) return ReadValueString(addr, len) end"
external val read_value_8 : int -> int = "ReadValue8"
external val read_value_16 : int -> int = "ReadValue16"
external val read_value_32 : int -> int = "ReadValue32"
external val read_value_float : int -> float = "ReadValueFloat"
external val read_value_string : int -> int -> string = "ReadValueString"
external val msg_box : string -> int -> () -> () =
"function(message, delay, n) MsgBox(message, delay) end"
external val set_screen_text : string -> () -> () =
"function(message, n) SetScreenText(message) end"
end
class decode 'a begin
val decode : int -> () -> 'a
end
instance decode u8 begin
let decode addr x = U8 (Dolphin.read_value_8 addr x)
end
instance decode s8 begin
let decode addr x = S8 (Dolphin.read_value_8 addr x)
end
instance decode u16 begin
let decode addr x = U16 (Dolphin.read_value_16 addr x)
end
instance decode s16 begin
let decode addr x = S16 (Dolphin.read_value_16 addr x)
end
instance decode u32 begin
let decode addr x = U32 (Dolphin.read_value_32 addr x)
end
instance decode s32 begin
let decode addr x = S32 (Dolphin.read_value_32 addr x)
external val msg_box : string -> int -> () = "MsgBox"
external val set_screen_text : string -> () = "SetScreenText"
end

23
main.ml
View file

@ -1,20 +1,25 @@
open import "prelude.ml"
open import "./save_context.ml"
open import "./pretty.ml"
open import "./dolphin.ml"
open import "./mem/decode.ml"
open import "./oot/save_context.ml"
let base_address = 0xf64120
let g_save_ctx_address = 0x11a5d0
let decode_save_ctx : () -> save_context = decode (base_address + g_save_ctx_address)
let onScriptStart () = ()
let main x =
let save_ctx = decode_save_ctx x
let display_save_ctx = "Save Context: " ^ (pretty save_ctx 0)
Dolphin.set_screen_text display_save_ctx x
let onScriptCancel () = ()
let () =
main ()
let onScriptUpdate () =
let save_ctx : save_context = decode (base_address + g_save_ctx_address)
let text : string = pretty save_ctx 0
Dolphin.set_screen_text text
let onStateLoaded () = ()
let onStateSaved () = ()

5
mem/decode.ml Normal file
View file

@ -0,0 +1,5 @@
open import "prelude.ml"
class decode 'a begin
val decode : int -> 'a
end

77
mem/int.ml Normal file
View file

@ -0,0 +1,77 @@
open import "prelude.ml"
open import "./decode.ml"
open import "../dolphin.ml"
type u8 =
U8 of int
instance show u8 begin
let show (U8 x) = (show x) ^ "_u8"
end
instance decode u8 begin
let decode addr = U8 (Dolphin.read_value_8 addr)
end
type s8 =
S8 of int
instance show s8 begin
let show (S8 x) = (show x) ^ "_s8"
end
instance decode s8 begin
let decode addr =
let u8 = Dolphin.read_value_8 addr
let signfix =
if u8 > 127 then
negate (256 - u8)
else
u8
S8 signfix
end
type u16 =
U16 of int
instance show u16 begin
let show (U16 x) = (show x) ^ "_u16"
end
type s16 =
S16 of int
instance show s16 begin
let show (S16 x) = (show x) ^ "_s16"
end
instance decode s16 begin
let decode addr =
let u16 = Dolphin.read_value_16 addr
let signfix =
if u16 > 32767 then
negate (65536 - u16)
else
u16
S16 signfix
end
type u32 =
U32 of int
instance show u32 begin
let show (U32 x) = (show x) ^ "_u32"
end
type s32 =
S32 of int
instance show s32 begin
let show (S32 x) =
let signfix =
if x > 2147483647 then
negate (4294967296 - x)
else
x
(show signfix) ^ "_s32"
end

26
oot/save_context.ml Normal file
View file

@ -0,0 +1,26 @@
open import "prelude.ml"
open import "../pretty.ml"
open import "../mem/decode.ml"
open import "../mem/int.ml"
type save_context = SaveContext of {
rupees: s16
}
instance decode save_context begin
let decode addr = SaveContext {
rupees = decode (addr + 0x0034)
}
end
instance prettyrecord save_context begin
let name _ = "SaveContext"
let fields (SaveContext x) =
[
("rupees", S x.rupees)
]
end
instance pretty save_context begin
let pretty = pretty_from_record
end

View file

@ -8,34 +8,28 @@ type prettyable =
| S : show 'a => 'a -> prettyable
| P : pretty 'a => 'a -> prettyable
let dummy_pretty = pretty
instance pretty prettyable begin
let pretty x w =
match x with
| S a -> show a
| P a -> dummy_pretty a w
end
let render_prettyable x w =
match x with
| S a -> show a
| P a -> pretty a w
class prettyrecord 'r begin
val name : 'r -> string
val fields : 'r -> list (string * prettyable)
end
instance prettyrecord 'a => pretty 'a begin
let pretty a w =
let rec smul s n =
if n <= 0 then
""
else
s ^ (smul s (n - 1))
let x = w + 2
let prep = smul " " w
let rf = fields a
let rec field_str acc l =
match l with
| [] -> acc
| Cons ((name, field), xs) -> field_str (acc ^ prep ^ " " ^ name ^ " = " ^ (pretty field x) ^ ",\n") xs
let body = field_str "" rf
(name a) ^ " {\n" ^ body ^ prep ^ "}"
end
let pretty_from_record a w =
let rec smul s n =
if n <= 0 then
""
else
s ^ (smul s (n - 1))
let x = w + 2
let prep = smul " " w
let rf = fields a
let render_field (name, field) =
name ^ " = " ^ (render_prettyable field x)
let field_str =
foldl (fun acc f -> acc ^ prep ^ " " ^ (render_field f) ^ ",\n") ""
let body = field_str rf
(name a) ^ " {\n" ^ body ^ prep ^ "}"

View file

@ -1,9 +1,290 @@
open import "prelude.ml"
open import "data/array.ml"
open import "./pretty.ml"
open import "./dolphin.ml"
type item =
| DekuStick
| DekuNut
| Bomb
| FairyBow
| FireArrow
| DinsFire
| FairySlingshot
| FairyOcarina
| OcarinaOfTime
| Bombchu_10
| Hookshot
| Longshot
| IceArrow
| FaroresWind
| Boomerang
| LensOfTruth
| MagicBean
| MegatonHammer
| LightArrow
| NayrusLove
| EmptyBottle
| RedPotionBottle
| GreenPotionBottle
| BluePotionBottle
| FairyBottle
| FishBottle
| FullMilkBottle
| RutosLetterBottle
| BlueFireBottle
| BugBottle
| BigPoeBottle
| HalfMilkBottle
| PoeBottle
| WeirdEgg
| Chicken
| ZeldasLetter
| KeatonMask
| SkullMask
| SpookyMask
| BunnyHood
| GoronMask
| ZoraMask
| GerudoMask
| MaskOfTruth
| SoldOut
| PocketEgg
| PocketCucco
| Cojiro
| OddMushroom
| OddPotion
| PoachersSaw
| BrokenGoronsSword
| Prescription
| EyeballFrog
| EyeDrops
| ClaimCheck
| FairyBowAndFireArrow
| FairyBowAndIceArrow
| FairyBowAndLightArrow
| KokiriSword
| MasterSword
| GiantsKnifeAndBiggoronsSword
| DekuShield
| HylianShield
| MirrorShield
| KokiriTunic
| GoronTunic
| ZoraTunic
| KokiriBoots
| IronBoots
| HoverBoots
| BulletBag_30
| BulletBag_40
| BulletBag_50
| Quiver_30
| BigQuiver_40
| BiggestQuiver_50
| BombBag_20
| BigBombBag_30
| BiggestBombBag_40
| GoronsBracelet
| SilverGauntlets
| GoldenGauntlets
| SilverScale
| GoldenScale
| BrokenGiantsKnife
| AdultsWallet
| GiantsWallet
| DekuSeeds_5
| FishingPole
| MinuetOfForest
| BoleroOfFire
| SerenadeOfWater
| RequiemOfSpirit
| NocturneOfShadow
| PreludeOfLight
| ZeldasLullaby
| EponasSong
| SariasSong
| SunsSong
| SongOfTime
| SongOfStorms
| ForestMedallion
| FireMedallion
| WaterMedallion
| SpiritMedallion
| ShadowMedallion
| LightMedallion
| KokirisEmerald
| GoronsRuby
| ZorasSapphire
| StoneOfAgony
| GerudosCard
| GoldSkulltulaToken
| HeartContainer
| PieceOfHeart_
| BossKey
| Compass
| DungeonMap
| SmallKey
| SmallMagicJar
| LargeMagicJar
| PieceOfHeart
| LonLonMilk
| RecoveryHeart
| GreenRupee
| BlueRupee
| RedRupee
| PurpleRupee
| HugeRupee
| DekuSticks_5
| DekuSticks_10
| DekuNuts_5
| DekuNuts_10
| Bombs_5
| Bombs_10
| Bombs_20
| Bombs_30
| Arrows_5_10
| Arrows_10_30
| Arrows_30_50
| DekuSeeds_30
| Bombchu_5
| Bombchu_20
| DekuStickCapacity_20
| DekuStickCapacity_30
| DekuNutCapacity_30
| DekuNutCapacity_40
| UnknownItem of u8
| NoItem
instance decode item begin
let decode addr x =
let (U8 id) = decode addr x
match id with
| 0xFF -> NoItem
end
instance show item begin
let show = function
| NoItem -> "No Item"
end
type sword =
| NoSword
| KokiriSword
| MasterSword
| BiggoronsSword
| UnknownSword of int
instance show sword begin
let show = function
| NoSword -> "No Sword"
| KokiriSword -> "Kokiri Sword"
| MasterSword -> "Master Sword"
| BiggoronsSword -> "Biggoron's Sword"
| UnknownSword x -> "Unknown Sword " ^ (show x)
end
type shield =
| NoShield
| DekuShield
| HylianShield
| MirrorShield
| UnknownShield of int
instance show shield begin
let show = function
| NoShield -> "No Shield"
| DekuShield -> "Deku Shield"
| HylianShield -> "Hylian Shield"
| MirrorShield -> "Mirror Shield"
| UnknownShield x -> "Unknown Shield " ^ (show x)
end
type tunic =
| KokiriTunic
| GoronTunic
| ZoraTunic
| UnknownTunic of int
instance show tunic begin
let show = function
| KokiriTunic -> "Kokiri Tunic"
| GoronTunic -> "Goron Tunic"
| ZoraTunic -> "Zora Tunic"
| UnknownTunic x -> "Unknown Tunic " ^ (show x)
end
type boots =
| KokiriBoots
| IronBoots
| HoverBoots
| UnknownBoots of int
instance show boots begin
let show = function
| KokiriBoots -> "Kokiri Boots"
| IronBoots -> "Iron Boots"
| HoverBoots -> "Hover Boots"
| UnknownBoots x -> "Unknown Boots " ^ (show x)
end
type equipment = Equipment of {
swordv: sword,
shieldv: shield,
tunicv: tunic,
bootsv: boots
}
external private val ( %% ) : int -> int -> int = "function(a, b) return a % b end"
instance decode equipment begin
let decode addr x =
let (U16 fields) = decode addr x
let swords = fields %% (0x000F + 1)
let shields = (fields // 8) %% (0x00F + 1)
let tunics = (fields // 16) %% (0x0F + 1)
let boots = (fields // 24) %% (0xF + 1)
let fsword =
match swords with
| 0 -> NoSword
| 1 -> KokiriSword
| 2 -> MasterSword
| 3 -> BiggoronsSword
| x -> UnknownSword x
let fshield =
match shields with
| 0 -> NoShield
| 1 -> DekuShield
| 2 -> HylianShield
| 3 -> MirrorShield
| x -> UnknownShield x
let ftunic =
match tunics with
| 1 -> KokiriTunic
| 2 -> GoronTunic
| 3 -> ZoraTunic
| x -> UnknownTunic x
let fboot =
match boots with
| 1 -> KokiriBoots
| 2 -> IronBoots
| 3 -> HoverBoots
| x -> UnknownBoots x
Equipment {
swordv = fsword,
shieldv = fshield,
tunicv = ftunic,
bootsv = fboot
}
end
instance prettyrecord equipment begin
let name _ = "Equipment"
let fields (Equipment x) =
[]
end
type item_equips = ItemEquips of {
button_item_b: u8,
button_item_c_left: u8,
@ -12,7 +293,7 @@ type item_equips = ItemEquips of {
button_slot_c_left: u8,
button_slot_c_down: u8,
button_slot_c_right: u8,
equipment: u16
equips: equipment
}
instance decode item_equips begin
@ -24,7 +305,7 @@ instance decode item_equips begin
button_slot_c_left = decode (addr + 0x04) x,
button_slot_c_down = decode (addr + 0x05) x,
button_slot_c_right = decode (addr + 0x06) x,
equipment = decode (addr + 0x08) x
equips = decode (addr + 0x08) x
}
end
@ -39,7 +320,49 @@ instance prettyrecord item_equips begin
("button_slot_c_left", S x.button_slot_c_left),
("button_slot_c_down", S x.button_slot_c_down),
("button_slot_c_right", S x.button_slot_c_right),
("equipment", S x.equipment)
("equips", P x.equips)
]
end
type inventory = Inventory of {
items: array u8,
ammo: array s8,
equipment: u16,
upgrades: u32,
quest_items: u32,
dungeon_items: array u8,
dungeon_keys: array s8,
defense_hearts: s8,
gs_tokens: s16
}
instance decode inventory begin
let decode addr x = Inventory {
items = init 24 (fun i -> decode (addr + 0x00 + i) x),
ammo = init 16 (fun i -> decode (addr + 0x18 + i) x),
equipment = decode (addr + 0x28) x,
upgrades = decode (addr + 0x2C) x,
quest_items = decode (addr + 0x30) x,
dungeon_items = init 20 (fun i -> decode (addr + 0x34 + i) x),
dungeon_keys = init 19 (fun i -> decode (addr + 0x48 + i) x),
defense_hearts = decode (addr + 0x5B) x,
gs_tokens = decode (addr + 0x5C) x
}
end
instance prettyrecord inventory begin
let name _ = "Inventory"
let fields (Inventory x) =
[
("items", S x.items),
("ammo", S x.ammo),
("equipment", S x.equipment),
("upgrades", S x.upgrades),
("quest_items", S x.quest_items),
("dungeon_items", S x.dungeon_items),
("dungeon_keys", S x.dungeon_keys),
("defense_hearts", S x.defense_hearts),
("gs_tokens", S x.gs_tokens)
]
end
@ -69,7 +392,12 @@ type save_context = SaveContext of {
bgs_flag: u8,
ocarina_game_reward: u8,
child_equips: item_equips,
adult_equips: item_equips
adult_equips: item_equips,
(* u32 unk_54, *)
(* char unk_58[0x0E], *)
saved_scene_num: s16,
equips: item_equips,
inventory: inventory
}
instance decode save_context begin
@ -97,7 +425,10 @@ instance decode save_context begin
bgs_flag = decode (addr + 0x003E) x,
ocarina_game_reward = decode (addr + 0x003F) x,
child_equips = decode (addr + 0x0040) x,
adult_equips = decode (addr + 0x004A) x
adult_equips = decode (addr + 0x004A) x,
saved_scene_num = decode (addr + 0x0066) x,
equips = decode (addr + 0x0068) x,
inventory = decode (addr + 0x0074) x
}
end
@ -127,6 +458,9 @@ instance prettyrecord save_context begin
("bgs_flag", S x.bgs_flag),
("ocarina_game_reward", S x.ocarina_game_reward),
("child_equips", P x.child_equips),
("adult_equips", P x.adult_equips)
("adult_equips", P x.adult_equips),
("saved_scene_num", S x.saved_scene_num),
("equips", P x.equips),
("inventory", P x.inventory)
]
end