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 [] 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: ThreeNode Group: ThreeNode Canvas: HTMLCanvasElement } 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 = "" let mutable loadedStepPath: string 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 renderFrame (frame: ReplayFrame) = selectedFrame <- frame match viewState with | None -> () | Some view -> view.Group.clear() addMesh view frame view.Renderer.render(view.Scene, view.Camera) 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) renderFrame selectedFrame 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" 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 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 loadStepArtifact (view: ViewState) (stepPath: string) = loadedStepPath <- Some stepPath let loader = createGLTFLoader () let projectId = JS.encodeURIComponent currentProjectId let runId = JS.encodeURIComponent currentRunId let url = sprintf "/api/artifacts/steps?projectId=%s&runId=%s&path=%s" projectId runId (JS.encodeURIComponent stepPath) setText "viewport-note" (sprintf "管线几何加载中 · %s" stepPath) loadGLTF loader url (fun gltf -> view.Group.clear() view.Group.add gltf.scene setText "viewport-note" (sprintf "管线几何 · %s" stepPath)) (fun _ -> setText "viewport-note" (sprintf "管线几何加载失败 · %s" stepPath)) 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 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] if loadedStepPath <> Some latest 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 "run-controls").addEventListener("submit", fun event -> event.preventDefault() startRun (selectedRun ())) boot ()