path: root/src/SomhairlesDream.Frontend/App.fs

module SomhairlesDream.Frontend.App

open System
open Browser.Dom
open Browser.Types
open Fable.Core
open Fable.Core.JsInterop
open SomhairlesDream.Frontend.Bindings
open SomhairlesDream.Shared

[<Erase>]
type SnapshotPayload =
    abstract projectId: string with get
    abstract runId: string with get
    abstract status: string with get
    abstract currentStepIndex: int with get
    abstract totalSteps: int with get
    abstract completedSteps: string array with get
    abstract lastHeartbeatAt: string with get
    abstract updatedAt: string with get
    abstract message: string with get
    abstract manifestUrl: string with get
    abstract error: string with get
    abstract isStale: bool with get

type RunSelection =
    { ProjectId: string
      RunId: string
      BaseId: string
      TargetId: string
      Render: bool }

type ViewState =
    { Renderer: ThreeRenderer
      Scene: ThreeNode
      Camera: ThreeCamera
      Group: ThreeNode
      Canvas: HTMLCanvasElement }

type LoadOwner =
    { ProjectId: string
      RunId: string
      Path: string }

type ViewMode =
    | FrameMode
    | StepMode

let frames = Replay.frames ()
let mutable viewState: ViewState option = None
let mutable selectedFrame = frames[0]
let mutable replayTimer: int option = None
let mutable replayIndex = 0
let mutable eventSource: EventSource option = None
let mutable currentProjectId = ""
let mutable currentRunId = ""
/// Bumped on every new step request and on every invalidation; only the
/// response matching the latest generation may repaint the viewport.
let mutable loadGeneration = 0
let mutable pendingLoad: (int * LoadOwner) option = None
let mutable loadedStep: LoadOwner option = None
let mutable viewMode = FrameMode
let mutable failedLoad: LoadOwner option = None
let mutable displayedNode: ThreeNode option = None
let mutable freezeRotation = false

let element id = document.getElementById(id)

let setText id value =
    (element id).textContent <- value

let setWidth id value =
    (element id).setAttribute("style", sprintf "width: %s" value)

let setStatusClass (status: string) =
    let host = element "status-chip"
    [| "idle"; "queued"; "running"; "succeeded"; "failed"; "stale" |]
    |> Array.iter (fun name -> host.classList.remove($"status-{name}"))
    host.classList.add($"status-{status}")
    host.setAttribute("data-status", status)

let statusName (payload: SnapshotPayload) =
    if payload.isStale then
        "stale"
    else
        match payload.status with
        | "complete" -> "succeeded"
        | "idle"
        | "queued"
        | "running"
        | "failed" as status -> status
        | _ -> "unknown"

let statusLabel (payload: SnapshotPayload) =
    match payload.status, payload.isStale with
    | _, true -> "心跳超时"
    | "idle", _ -> "待机"
    | "queued", _ -> "排队中"
    | "running", _ -> "运行中"
    | "complete", _ -> "已完成"
    | "failed", _ -> "失败"
    | _ -> "未知状态"

let addMesh (view: ViewState) (frame: ReplayFrame) =
    let geometry = createBufferGeometry ()
    let positions = MeshData.positionData frame.Mesh
    let indices = MeshData.triangleIndices frame.Mesh
    geometry.setAttribute("position", createFloat32BufferAttribute(positions, 3)) |> ignore
    geometry.setIndex(createUint32BufferAttribute indices) |> ignore
    geometry.computeVertexNormals()

    let color =
        match frame.Version with
        | 1 -> "#d7a948"
        | 2 -> "#efe4c4"
        | _ -> "#a7c7c0"

    let material =
        createMeshStandardMaterial (
            createObj
                [ "color" ==> color
                  "roughness" ==> 0.36
                  "metalness" ==> 0.72 ]
        )

    let mesh = createMesh(geometry, material)
    view.Group.add(mesh)

let clearGroup (group: ThreeNode) =
    group.children |> Array.iter disposeNodeResources
    group.clear ()

let invalidateLoads () =
    loadGeneration <- loadGeneration + 1
    pendingLoad <- None
    failedLoad <- None

let renderFrame (frame: ReplayFrame) =
    selectedFrame <- frame
    displayedNode <- None
    invalidateLoads ()
    viewMode <- FrameMode

    match viewState with
    | None -> ()
    | Some view ->
        clearGroup view.Group
        addMesh view frame
        view.Renderer.render(view.Scene, view.Camera)

let frameObject (view: ViewState) (node: ThreeNode) =
    let box = createBox3 ()
    box.setFromObject node |> ignore

    if not (box.isEmpty ()) then
        let center = createVector3 ()
        let size = createVector3 ()
        box.getCenter center |> ignore
        box.getSize size |> ignore
        let radius = 0.5 * size.length ()

        if radius > 0.000001 then
            node.position.set(-center.x, -center.y, -center.z) |> ignore
            let camera = view.Camera
            let width = max 1.0 (float view.Canvas.clientWidth)
            let height = max 1.0 (float view.Canvas.clientHeight)
            let aspect = width / height
            camera.aspect <- aspect
            let fovY = camera.fov * Math.PI / 180.0
            let fovX = 2.0 * atan (tan (fovY / 2.0) * aspect)
            let limitingFov = min fovY fovX
            let distance = 1.28 * radius / sin (limitingFov / 2.0)
            let dirX, dirY, dirZ = 0.62, 0.45, 0.70
            let norm = sqrt (dirX * dirX + dirY * dirY + dirZ * dirZ)
            camera.position.set(dirX / norm * distance, dirY / norm * distance, dirZ / norm * distance)
            |> ignore
            camera.near <- max (distance * 0.01) (distance - radius * 2.5)
            camera.far <- distance + radius * 4.0
            camera.lookAt(0.0, 0.0, 0.0)
            camera.updateProjectionMatrix ()

let resizeView (view: ViewState) =
    let width = max 1.0 (float view.Canvas.clientWidth)
    let height = max 1.0 (float view.Canvas.clientHeight)
    view.Renderer.setSize(width, height, false)
    view.Camera.aspect <- width / height
    view.Camera.updateProjectionMatrix()

    match displayedNode with
    | Some node ->
        frameObject view node
        view.Renderer.render(view.Scene, view.Camera)
    | None -> view.Renderer.render(view.Scene, view.Camera)

let initializeView () =
    let canvas = document.getElementById("viewport-canvas") :?> HTMLCanvasElement
    let width = max 1.0 (float canvas.clientWidth)
    let height = max 1.0 (float canvas.clientHeight)
    let renderer =
        createRenderer (
            createObj
                [ "canvas" ==> canvas
                  "antialias" ==> true
                  "alpha" ==> true ]
        )

    renderer.setPixelRatio(window.devicePixelRatio)
    renderer.setSize(width, height, false)
    let scene = createScene()
    scene.background <- createColor("#11171a")
    let camera = createPerspectiveCamera(34.0, width / height, 0.1, 100.0)
    camera.position.set(6.4, 4.6, 7.2) |> ignore
    camera.lookAt(0.0, 1.2, 0.0)
    let group = createGroup()
    scene.add(group)
    scene.add(createAmbientLight("#f0e6c8", 1.9))
    let keyLight = createDirectionalLight("#f2c76b", 2.8)
    keyLight.position.set(4.0, 7.0, 5.0) |> ignore
    scene.add(keyLight)

    let view =
        { Renderer = renderer
          Scene = scene
          Camera = camera
          Group = group
          Canvas = canvas }

    viewState <- Some view
    freezeRotation <- (queryParam "freeze") = "1"
    exposeViewerDebug camera scene group canvas
    renderFrame selectedFrame
    window.addEventListener("resize", fun _ -> resizeView view)

    let rec animate (_: float) =
        if not freezeRotation then
            group.rotation.y <- group.rotation.y + 0.003

        renderer.render(scene, camera)
        requestAnimationFrame animate |> ignore

    requestAnimationFrame animate |> ignore

let fallbackView () =
    setText "viewport-note" "WebGL 视图待命 · 已保留重建数据"
    (element "viewport-panel").classList.add("viewport-fallback")

let setNoteRetryable (retryable: bool) =
    let note = element "viewport-note"

    if retryable then
        note.classList.add("is-retryable")
    else
        note.classList.remove("is-retryable")

let showFrameMetadata (frame: ReplayFrame) =
    setText "mesh-label" frame.Label
    setText "timeline-current" (sprintf "V%02d · %s" frame.Version frame.Label)

let setManifestLink (payload: SnapshotPayload) =
    let link = element "artifact-manifest-link"

    match payload.manifestUrl with
    | value when String.IsNullOrWhiteSpace(value) ->
        link.removeAttribute("href")
        link.classList.add("is-hidden")
    | value ->
        link.setAttribute("href", value)
        link.classList.remove("is-hidden")

let startStepLoad (view: ViewState) (owner: LoadOwner) =
    let generation = loadGeneration + 1
    loadGeneration <- generation
    pendingLoad <- Some(generation, owner)
    viewMode <- StepMode
    failedLoad <- None
    setNoteRetryable false
    let loader = createGLTFLoader ()
    let projectId = JS.encodeURIComponent owner.ProjectId
    let runId = JS.encodeURIComponent owner.RunId
    let url = sprintf "/api/artifacts/steps?projectId=%s&runId=%s&path=%s" projectId runId (JS.encodeURIComponent owner.Path)
    setText "viewport-note" (sprintf "管线几何加载中 · %s" owner.Path)

    loadGLTF loader url
        (fun gltf ->
            if pendingLoad = Some(generation, owner) then
                pendingLoad <- None
                clearGroup view.Group
                view.Group.add gltf.scene
                displayedNode <- Some gltf.scene
                loadedStep <- Some owner
                frameObject view gltf.scene
                view.Renderer.render(view.Scene, view.Camera)
                setText "viewport-note" (sprintf "管线几何 · %s" owner.Path)
            else
                disposeNodeResources gltf.scene)
        (fun _ ->
            if pendingLoad = Some(generation, owner) then
                pendingLoad <- None
                loadedStep <- None
                failedLoad <- Some owner
                setNoteRetryable true
                setText "viewport-note" (sprintf "管线几何加载失败 · %s" owner.Path))

let loadStepArtifact (view: ViewState) (stepPath: string) =
    let owner =
        { ProjectId = currentProjectId
          RunId = currentRunId
          Path = stepPath }

    match pendingLoad with
    | Some (_, pending) when pending = owner -> ()
    | _ -> startStepLoad view owner

let retryFailedLoad () =
    match viewState, failedLoad with
    | Some view, Some owner when owner.ProjectId = currentProjectId && owner.RunId = currentRunId ->
        loadStepArtifact view owner.Path
    | _ -> ()

let updateState (payload: SnapshotPayload) =
    let status = statusName payload
    setStatusClass status
    setText "status-label" (statusLabel payload)

    let message =
        if payload.status = "failed" && not (String.IsNullOrWhiteSpace(payload.error)) then
            payload.error
        else
            payload.message

    setText "run-message" message
    setText "project-id" payload.projectId
    setText "run-id" payload.runId

    if currentProjectId <> payload.projectId || currentRunId <> payload.runId then
        invalidateLoads ()
        displayedNode <- None

    currentProjectId <- payload.projectId
    currentRunId <- payload.runId

    let currentVersion = max 0 (payload.currentStepIndex + 1)
    setText "target-version" (sprintf "V%02d" payload.totalSteps)
    setText "current-version" (sprintf "V%02d" currentVersion)
    setText "version-readout" (sprintf "%02d / %02d" currentVersion payload.totalSteps)
    setText "updated-at" payload.updatedAt

    let progress =
        if payload.totalSteps <= 0 then 0.0
        else min 100.0 (float currentVersion / float payload.totalSteps * 100.0)

    setWidth "progress-fill" (sprintf "%.0f%%" progress)

    let frame =
        frames
        |> Array.tryFind (fun candidate -> candidate.Version = currentVersion)
        |> Option.defaultValue selectedFrame

    setManifestLink payload

    let completedSteps =
        if isNull (box payload.completedSteps) then [||] else payload.completedSteps

    match viewState, completedSteps with
    | Some view, steps ->
        if steps.Length = 0 then
            showFrameMetadata frame
            renderFrame frame
        else
            let latest = steps[steps.Length - 1]
            let owner =
                { ProjectId = payload.projectId
                  RunId = payload.runId
                  Path = latest }

            if loadedStep <> Some owner then
                loadStepArtifact view latest

            setText "mesh-label" latest
    | None, steps ->
        if steps.Length > 0 then
            setText "mesh-label" steps[steps.Length - 1]
        else
            showFrameMetadata frame

let updateStreamState message =
    setText "stream-state" message

let toggleReplay () =
    match replayTimer with
    | Some handle ->
        clearInterval handle
        replayTimer <- None
        setText "replay-button" "重建演示"
        setText "replay-state" "演示已暂停"
    | None ->
        replayIndex <- 0
        setText "replay-button" "暂停重建"
        setText "replay-state" "重建中 · 几何逐帧替换"

        let tick () =
            if replayIndex >= frames.Length then
                match replayTimer with
                | Some handle -> clearInterval handle
                | None -> ()

                replayTimer <- None
                setText "replay-button" "重建演示"
                setText "replay-state" "重建完成 · 几何已更新"
            else
                let frame = frames[replayIndex]
                showFrameMetadata frame
                renderFrame frame
                setText "replay-state" (sprintf "重建中 · V%02d %s" frame.Version frame.Label)
                replayIndex <- replayIndex + 1

        tick ()
        replayTimer <- Some(setInterval tick 900)

let disconnectFromServer () =
    match eventSource with
    | Some source ->
        source.close()
        eventSource <- None
    | None -> ()

let connectToServer (selection: RunSelection) =
    disconnectFromServer ()
    let projectId = JS.encodeURIComponent selection.ProjectId
    let runId = JS.encodeURIComponent selection.RunId
    let source = createEventSource (sprintf "/api/runs/events?projectId=%s&runId=%s" projectId runId)
    eventSource <- Some source

    source.onmessage <- fun event ->
        let payload = JS.JSON.parse(event.data) :?> SnapshotPayload
        updateState payload
        updateStreamState "实时链路 · SSE 已连接"

    source.onerror <- fun _ -> updateStreamState "实时链路 · 等待自动重连"

let inputValue id =
    (element id :?> HtmlInput).value

let selectedRun () =
    { ProjectId = inputValue "project-id-input"
      RunId = inputValue "run-id-input"
      BaseId = inputValue "base-id-input"
      TargetId = inputValue "target-id-input"
      Render = (element "run-render-input" :?> HtmlInput).``checked`` }

let startRun (selection: RunSelection) =
    let requestBody =
        createObj
            [ "projectId" ==> selection.ProjectId
              "runId" ==> selection.RunId
              "baseId" ==> selection.BaseId
              "targetId" ==> selection.TargetId
              "render" ==> selection.Render ]

    let requestOptions =
        createObj
            [ "method" ==> "POST"
              "headers" ==> createObj [ "Content-Type" ==> "application/json" ]
              "body" ==> JS.JSON.stringify requestBody ]

    setText "run-message" "正在启动设计运行"
    updateStreamState "实时链路 · 等待服务端确认"

    async {
        try
            let! response = fetch ("/api/runs/start", requestOptions) |> Async.AwaitPromise

            if response.ok then
                let! value = response.json() |> Async.AwaitPromise
                let payload = value :?> SnapshotPayload
                updateState payload
                connectToServer selection
                updateStreamState "实时链路 · SSE 已连接"
            else
                setText "run-message" (sprintf "启动失败 · HTTP %d" response.status)
                updateStreamState "实时链路 · 启动失败"
        with _ ->
            setText "run-message" "启动失败 · 无法连接服务端"
            updateStreamState "实时链路 · 连接失败"
    }
    |> Async.StartImmediate

let boot () =
    showFrameMetadata frames[0]

    try
        initializeView ()
    with _ ->
        fallbackView ()

    (element "replay-button").addEventListener("click", fun _ -> toggleReplay ())
    (element "viewport-note").addEventListener("click", fun _ -> retryFailedLoad ())
    (element "run-controls").addEventListener("submit", fun event ->
        event.preventDefault()
        startRun (selectedRun ()))

boot ()