path: root/ocaml/lib/boot.ml

open Noun
open Nock
open Serial
open State

let debug_enabled () =
  match Sys.getenv_opt "NEOVERE_BOOT_DEBUG" with
  | None -> false
  | Some value ->
      let v = String.lowercase_ascii value in
      not (v = "0" || v = "false" || v = "off")

let log fmt =
  if debug_enabled () then
    Printf.ksprintf (fun msg -> Printf.printf "[boot] %s\n%!" msg) fmt
  else
    Printf.ksprintf (fun _ -> ()) fmt

let count_list noun =
  let rec loop acc current =
    match current with
    | Atom z when Z.equal z Z.zero -> acc
    | Cell (_, t) -> loop (acc + 1) t
    | _ -> acc
  in
  loop 0 noun

type error =
  | Invalid_pill of string
  | Unsupported of string

let cue_file ?(verbose=false) path =
  let ic = open_in_bin path in
  let len = in_channel_length ic in
  let data = really_input_string ic len in
  close_in ic;
  cue ~verbose (Bytes.of_string data)

let atom_int n = atom (Z.of_int n)

let lifecycle_formula =
  (* [2 [0 3] [0 2]] *)
  let axis03 = cell (atom_int 0) (atom_int 3) in
  let axis02 = cell (atom_int 0) (atom_int 2) in
  cell (atom_int 2) (cell axis03 axis02)

let run_lifecycle events =
  log "running lifecycle formula [2 [0 3] [0 2]] on event list";
  let gate = nock_on events lifecycle_formula in
  log "lifecycle formula succeeded, extracting kernel from slot 7";
  let kernel = slot (Z.of_int 7) gate in
  log "kernel extracted, is_cell=%b" (Noun.is_cell kernel);
  kernel

let parse_ivory noun =
  match noun with
  | Cell (_tag, events) -> Ok events
  | _ -> Error (Invalid_pill "ivory pill must be a cell")

let boot_ivory state path =
  log "loading ivory pill: %s" path;
  let cue_start = Sys.time () in
  let noun = cue_file ~verbose:(debug_enabled ()) path in
  let cue_elapsed = Sys.time () -. cue_start in
  log "cue complete in %.3fs" cue_elapsed;
  match parse_ivory noun with
  | Error e -> Error e
  | Ok events ->
      let event_count = count_list events in
      log "ivory event count=%d" event_count;
      log "running lifecycle formula";
      let life_start = Sys.time () in
      let result =
        try Ok (run_lifecycle events) with
        | Exit -> Error (Invalid_pill "ivory lifecycle failed (Exit)")
        | exn -> Error (Invalid_pill (Printexc.to_string exn))
      in
      begin match result with
      | Error err ->
          log "lifecycle failed";
          Error err
      | Ok kernel ->
          let life_elapsed = Sys.time () -. life_start in
          log "lifecycle complete in %.3fs" life_elapsed;
          log "kernel is_cell=%b" (Noun.is_cell kernel);
          let events_played = Int64.of_int event_count in
          boot ~events_played state kernel;
          Ok ()
      end

let parse_solid noun =
  match noun with
  | Cell (tag, rest) ->
      let pill_tag = Z.of_int 0x6c6c6970 in
      begin match tag with
      | Atom z when Z.equal z pill_tag ->
          (* Structure is flat 4-tuple: [%pill typ bot mod use] *)
          begin match rest with
          | Cell (typ, Cell (bot, Cell (mod_, use_))) ->
              (* Check typ is %solid (0x64696c6f73) or %olid (0x64696c6f) *)
              begin match typ with
              | Atom z when Z.equal z (Z.of_int 0x64696c6f73) || Z.equal z (Z.of_int 0x64696c6f) ->
                  Ok (bot, mod_, use_)
              | Atom z ->
                  let typ_hex = Z.format "%x" z in
                  log "got pill type tag: 0x%s (expected 'solid' = 0x64696c6f73)" typ_hex;
                  Error (Unsupported (Printf.sprintf "unsupported pill type: 0x%s" typ_hex))
              | _ -> Error (Unsupported "pill type must be atom")
              end
          | _ -> Error (Invalid_pill "expected flat 4-tuple [%pill typ bot mod use]")
          end
      | _ -> Error (Invalid_pill "missing %pill tag")
      end
  | _ -> Error (Invalid_pill "pill must be a cell")

let rec list_fold noun acc =
  match noun with
  | Atom z when Z.equal z Z.zero -> List.rev acc
  | Cell (h, t) -> list_fold t (h :: acc)
  | _ -> raise Exit

let rec take n lst =
  if n <= 0 then []
  else match lst with
    | [] -> []
    | x :: xs -> x :: take (n - 1) xs

(* Convert ASCII string to atom (bytes in little-endian order) *)
let atom_of_string s =
  if String.length s = 0 then atom Z.zero
  else
    let bytes = Bytes.of_string s in
    atom (Z.of_bits (Bytes.to_string bytes))

(* Urbit time functions matching vere/pkg/vere/time.c *)

(* Convert Unix seconds to Urbit seconds *)
let urbit_sec_of_unix_sec unix_sec =
  (* Urbit epoch offset: 0x8000000cce9e0d80 *)
  let urbit_epoch = Z.of_string "0x8000000cce9e0d80" in
  Z.add urbit_epoch (Z.of_int unix_sec)

(* Convert microseconds to Urbit fracto-seconds *)
let urbit_fsc_of_usec usec =
  (* (usec * 65536 / 1000000) << 48 *)
  let usec_z = Z.of_int usec in
  let scaled = Z.div (Z.mul usec_z (Z.of_int 65536)) (Z.of_int 1000000) in
  Z.shift_left scaled 48

(* Get current Urbit time as 128-bit atom [low_64 high_64] *)
let urbit_time_now () =
  let time_f = Unix.gettimeofday () in
  let unix_sec = int_of_float time_f in
  let usec = int_of_float ((time_f -. float_of_int unix_sec) *. 1_000_000.0) in

  let urbit_sec = urbit_sec_of_unix_sec unix_sec in
  let urbit_fsc = urbit_fsc_of_usec usec in

  (* Combine into 128-bit atom:
     - Bits 0-63: fractional seconds (urbit_fsc)
     - Bits 64-127: seconds (urbit_sec shifted left 64 bits) *)
  let time_128 = Z.logor urbit_fsc (Z.shift_left urbit_sec 64) in
  atom time_128

let boot_solid_lifecycle state path =
  log "loading solid pill: %s" path;
  let cue_start = Sys.time () in
  let noun = cue_file ~verbose:(debug_enabled ()) path in
  let cue_elapsed = Sys.time () -. cue_start in
  log "cue complete in %.3fs" cue_elapsed;

  match parse_solid noun with
  | Error e -> Error e
  | Ok (bot, mod_, use_) ->
      log "parsing event lists...";
      let bot_list = list_fold bot [] in
      let mod_list = list_fold mod_ [] in
      let use_list = list_fold use_ [] in
      log "bot events: %d, mod events: %d, use events: %d"
        (List.length bot_list) (List.length mod_list) (List.length use_list);

      (* Add system events like mars.c lines 1741-1767 *)
      let arvo_wire =
        (* [/~/ %arvo ~] - wire for system events *)
        cell (cell (atom (Z.of_int 0)) (atom_of_string "arvo")) (atom Z.zero)
      in

      (* Add 4 system events to mod list (prepended in reverse order) *)
      let mod_list =
        (* 1. wack - entropy (16 words of 0xdeadbeef) *)
        let eny_bytes = Bytes.create (16 * 4) in
        for i = 0 to 15 do
          Bytes.set_int32_le eny_bytes (i * 4) (Int32.of_int 0xdeadbeef)
        done;
        let eny_atom = atom (Z.of_bits (Bytes.to_string eny_bytes)) in
        let wack_card = cell (atom_of_string "wack") eny_atom in
        let wack = cell arvo_wire wack_card in

        (* 2. whom - identity (fake ship ~zod = 0) *)
        let whom_card = cell (atom_of_string "whom") (atom Z.zero) in
        let whom = cell arvo_wire whom_card in

        (* 3. verb - verbosity (verbose = no) *)
        let verb_card = cell (atom_of_string "verb") (cell (atom Z.zero) (atom Z.zero)) in
        let verb = cell arvo_wire verb_card in

        (* 4. wyrd - version negotiation *)
        let sen = atom_of_string "0v1s.vu178" in
        let ver = cell (atom_of_string "vere")
                  (cell (atom_of_string "live")
                   (cell (atom_of_string "3.5") (atom Z.zero))) in
        let kel =
          cell (cell (atom_of_string "zuse") (atom (Z.of_int 409)))
          (cell (cell (atom_of_string "lull") (atom (Z.of_int 321)))
          (cell (cell (atom_of_string "arvo") (atom (Z.of_int 235)))
          (cell (cell (atom_of_string "hoon") (atom (Z.of_int 136)))
          (cell (cell (atom_of_string "nock") (atom (Z.of_int 4)))
           (atom Z.zero)))))
        in
        let wyrd_card = cell (atom_of_string "wyrd") (cell (cell sen ver) kel) in
        let wyrd = cell arvo_wire wyrd_card in

        wack :: whom :: verb :: wyrd :: mod_list
      in

      (* Add boot event to use list *)
      let use_list =
        (* [/d/term/1 [%boot lit venue]] where venue = [%fake ~zod] *)
        let boot_wire =
          cell (atom_of_string "d")
          (cell (atom_of_string "term")
          (cell (atom (Z.of_int 1)) (atom Z.zero)))
        in
        let venue = cell (atom_of_string "fake") (atom Z.zero) in
        let boot_card = cell (atom_of_string "boot") (cell (atom Z.zero) venue) in
        let boot_event = cell boot_wire boot_card in
        boot_event :: use_list
      in

      log "after adding system events:";
      log "  bot events: %d, mod events: %d, use events: %d"
        (List.length bot_list) (List.length mod_list) (List.length use_list);

      (* Build event list like mars.c:1815-1835 *)
      (* Bot events are NOT timestamped, mod/use events ARE timestamped *)
      log "building event list (bot bare, mod/use timestamped)...";
      let now = urbit_time_now () in
      let bit = atom (Z.shift_left Z.one 48) in  (* 2^48 = 1/2^16 seconds increment *)

      (* Start with bot events (bare, not timestamped) *)
      let event_list = List.rev bot_list in

      (* Add mod+use events (timestamped) *)
      let mod_use = mod_list @ use_list in
      let rec timestamp_and_add events current_time acc =
        match events with
        | [] -> List.rev acc
        | event :: rest ->
            let timestamped = cell current_time event in
            let next_time = match (current_time, bit) with
              | (Atom t, Atom b) -> atom (Z.add t b)
              | _ -> failwith "time must be atoms"
            in
            timestamp_and_add rest next_time (timestamped :: acc)
      in
      let timestamped_mod_use = timestamp_and_add mod_use now [] in
      let full_event_list = event_list @ timestamped_mod_use in

      log "built event list with %d events" (List.length full_event_list);
      log "  %d bot (bare) + %d mod/use (timestamped)"
        (List.length bot_list) (List.length timestamped_mod_use);

      (* Convert to noun list structure *)
      let rec build_noun_list = function
        | [] -> atom Z.zero
        | h :: t -> cell h (build_noun_list t)
      in
      let event_noun = build_noun_list full_event_list in

      (* Run lifecycle formula on full event list *)
      log "running lifecycle formula on full event list...";
      let life_start = Sys.time () in
      let result =
        try Ok (run_lifecycle event_noun) with
        | Exit -> Error (Invalid_pill "lifecycle formula failed (Exit)")
        | exn -> Error (Invalid_pill (Printexc.to_string exn))
      in
      begin match result with
      | Error err ->
          log "lifecycle failed: %s" (match err with Invalid_pill s | Unsupported s -> s);
          Error err
      | Ok kernel ->
          let life_elapsed = Sys.time () -. life_start in
          log "lifecycle complete in %.3fs" life_elapsed;
          let events_played = Int64.of_int (List.length full_event_list) in
          boot ~events_played state kernel;
          Ok ()
      end

let boot_solid ?limit ?(apply = poke) state path =
  log "loading solid pill: %s" path;
  let cue_start = Sys.time () in
  let noun = cue_file ~verbose:(debug_enabled ()) path in
  let cue_elapsed = Sys.time () -. cue_start in
  log "cue complete in %.3fs" cue_elapsed;

  match parse_solid noun with
  | Error e -> Error e
  | Ok (bot, mod_, use_) ->
      log "parsing event lists...";
      let bot_list = list_fold bot [] in
      let mod_list = list_fold mod_ [] in
      let use_list = list_fold use_ [] in
      log "bot events: %d, mod events: %d, use events: %d"
        (List.length bot_list) (List.length mod_list) (List.length use_list);

      (* Add system events like mars.c lines 1741-1767 *)
      let arvo_wire =
        (* [/~/ %arvo ~] - wire for system events *)
        cell (cell (atom (Z.of_int 0)) (atom_of_string "arvo")) (atom Z.zero)
      in

      (* Add 4 system events to mod list (prepended in reverse order) *)
      (* Each event is [wire card] *)
      let mod_list =
        (* 1. wack - entropy (16 words of 0xdeadbeef) *)
        let eny_bytes = Bytes.create (16 * 4) in
        for i = 0 to 15 do
          Bytes.set_int32_le eny_bytes (i * 4) (Int32.of_int 0xdeadbeef)
        done;
        let eny_atom = atom (Z.of_bits (Bytes.to_string eny_bytes)) in
        let wack_card = cell (atom_of_string "wack") eny_atom in
        let wack = cell arvo_wire wack_card in

        (* 2. whom - identity (fake ship ~zod = 0) *)
        let whom_card = cell (atom_of_string "whom") (atom Z.zero) in
        let whom = cell arvo_wire whom_card in

        (* 3. verb - verbosity (verbose = no) *)
        let verb_card = cell (atom_of_string "verb") (cell (atom Z.zero) (atom Z.zero)) in
        let verb = cell arvo_wire verb_card in

        (* 4. wyrd - version negotiation *)
        let sen = atom_of_string "0v1s.vu178" in
        let ver = cell (atom_of_string "vere")
                  (cell (atom_of_string "live")
                   (cell (atom_of_string "3.5") (atom Z.zero))) in
        let kel =
          cell (cell (atom_of_string "zuse") (atom (Z.of_int 409)))
          (cell (cell (atom_of_string "lull") (atom (Z.of_int 321)))
          (cell (cell (atom_of_string "arvo") (atom (Z.of_int 235)))
          (cell (cell (atom_of_string "hoon") (atom (Z.of_int 136)))
          (cell (cell (atom_of_string "nock") (atom (Z.of_int 4)))
           (atom Z.zero)))))
        in
        let wyrd_card = cell (atom_of_string "wyrd") (cell (cell sen ver) kel) in
        let wyrd = cell arvo_wire wyrd_card in

        wack :: whom :: verb :: wyrd :: mod_list
      in

      (* Add boot event to use list *)
      let use_list =
        (* [/d/term/1 [%boot lit venue]] where venue = [%fake ~zod] *)
        let boot_wire =
          cell (atom_of_string "d")
          (cell (atom_of_string "term")
          (cell (atom (Z.of_int 1)) (atom Z.zero)))
        in
        let venue = cell (atom_of_string "fake") (atom Z.zero) in
        let boot_card = cell (atom_of_string "boot") (cell (atom Z.zero) venue) in
        let boot_event = cell boot_wire boot_card in
        boot_event :: use_list
      in

      log "after adding system events:";
      log "  bot events: %d, mod events: %d, use events: %d"
        (List.length bot_list) (List.length mod_list) (List.length use_list);

      let all_events = List.concat [ bot_list; mod_list; use_list ] in
      let all_events = match limit with
        | None -> all_events
        | Some n ->
            log "limiting to first %d events" n;
            take n all_events
      in

      (* Timestamp events like mars.c lines 1815-1836 *)
      log "timestamping %d events..." (List.length all_events);
      let now = urbit_time_now () in
      let bit = atom (Z.shift_left Z.one 48) in  (* 2^48 = 1/2^16 seconds increment *)

      let timestamped_events =
        let rec timestamp_loop remaining current_time acc =
          match remaining with
          | [] -> List.rev acc
          | event :: rest ->
              (* Each event becomes [timestamp event] *)
              let timestamped = cell current_time event in
              (* Increment time by bit (2^48) *)
              let next_time = match (current_time, bit) with
                | (Atom t, Atom b) -> atom (Z.add t b)
                | _ -> failwith "time must be atoms"
              in
              timestamp_loop rest next_time (timestamped :: acc)
        in
        timestamp_loop all_events now []
      in

      log "processing %d timestamped events..." (List.length timestamped_events);
      let counter = ref 0 in
      List.iter (fun event ->
        incr counter;
        if !counter mod 10 = 0 then
          log "processed %d/%d events" !counter (List.length timestamped_events);
        ignore (apply state event)
      ) timestamped_events;
      log "all events processed";
      Ok ()