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 ManifestStep = abstract stepIndex: int with get abstract artifactPath: string with get [] type ManifestPayload = abstract projectId: string with get abstract runId: string with get abstract status: string with get abstract steps: ManifestStep array 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 Controls: obj } // Auto-spin pauses while the visitor is dragging or zooming the model and // resumes a few seconds after the last interaction, so inspecting a stage // (dish, RTG, mast) is never fought by the idle animation. let mutable lastInteractionMs = 0.0 let idleSpinDelayMs = 3500.0 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 = "" /// Checkpoint artifact paths published by the currently selected run. Empty /// when no real history exists and the placeholder fallback is shown. let mutable historicalSteps: string array = [||] /// Index into historicalSteps of the user-pinned historical checkpoint. /// None means the viewport follows the latest published checkpoint. let mutable pinnedIndex: int option = None /// 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 /// Last failed step load plus whether it was a historical (replay) load, so /// the retry affordance re-requests the same owner in the same scope. let mutable failedLoad: (LoadOwner * bool) 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 () // Re-sync the orbit target after every auto-fit so drag/zoom // pivots around the freshly centered model. match view.Controls with | null -> () | controls -> setControlsTarget controls 0.0 0.0 0.0 updateControls controls 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, 0.0, 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 controls = createOrbitControls camera canvas setControlsTarget controls 0.0 0.0 0.0 setControlsDamping controls true setControlsAutoRotateSpeed controls 0.7 let view = { Renderer = renderer Scene = scene Camera = camera Group = group Canvas = canvas Controls = controls } viewState <- Some view freezeRotation <- (queryParam "freeze") = "1" setControlsAutoRotate controls (not freezeRotation) exposeViewerDebug camera scene group canvas controls renderFrame selectedFrame window.addEventListener("resize", fun _ -> resizeView view) canvas.addEventListener("pointerdown", fun _ -> lastInteractionMs <- JS.Constructors.Date.now ()) canvas.addEventListener("wheel", fun _ -> lastInteractionMs <- JS.Constructors.Date.now ()) canvas.addEventListener("touchstart", fun _ -> lastInteractionMs <- JS.Constructors.Date.now ()) let rec animate (nowMs: float) = updateControls controls if not freezeRotation then group.rotation.y <- group.rotation.y + 0.003 let interacting = nowMs - lastInteractionMs < idleSpinDelayMs setControlsAutoRotate controls (not freezeRotation && not interacting) 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 updateFollowButton () = if Array.length historicalSteps > 0 && pinnedIndex.IsSome then (element "follow-button").removeAttribute("disabled") setText "follow-button" "跟随最新" else (element "follow-button").setAttribute("disabled", "disabled") if Array.length historicalSteps > 0 then setText "follow-button" "跟随最新 · 已开启" else setText "follow-button" "跟随最新" let stopReplay () = match replayTimer with | Some handle -> clearInterval handle replayTimer <- None | None -> () let showFrameMetadata (frame: ReplayFrame) = setText "mesh-label" (sprintf "占位 · %s" 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) (historical: bool) = 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) if historical then setText "viewport-note" (sprintf "历史几何加载中 · %s" owner.Path) else 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) if historical then setText "viewport-note" (sprintf "历史几何 · %s" owner.Path) else 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, historical) setNoteRetryable true if historical then setText "viewport-note" (sprintf "历史几何加载失败 · %s" owner.Path) else setText "viewport-note" (sprintf "管线几何加载失败 · %s" owner.Path)) let loadStepArtifact (view: ViewState) (stepPath: string) (historical: bool) = let owner = { ProjectId = currentProjectId RunId = currentRunId Path = stepPath } match pendingLoad with | Some (_, pending) when pending = owner -> () | _ -> startStepLoad view owner historical let retryFailedLoad () = match viewState, failedLoad with | Some view, Some (owner, historical) when owner.ProjectId = currentProjectId && owner.RunId = currentRunId -> loadStepArtifact view owner.Path historical | _ -> () let applyHistoricalStep (index: int) (duringPlayback: bool) = match viewState with | Some view when index >= 0 && index < Array.length historicalSteps -> pinnedIndex <- Some index let path = historicalSteps[index] let version = index + 1 setText "mesh-label" (sprintf "历史 · %s" path) setText "timeline-current" (sprintf "V%02d · 历史回放 · %s" version path) loadStepArtifact view path true if duringPlayback then setText "replay-state" (sprintf "历史回放中 · V%02d (%d/%d)" version version (Array.length historicalSteps)) else setText "replay-state" (sprintf "历史回放 · 已固定 V%02d" version) | _ -> () let rec renderTimeline () = let track = element "timeline-track" clearChildren track let line = document.createElement("span") line.className <- "timeline-line" line.setAttribute("aria-hidden", "true") track.appendChild line |> ignore if Array.length historicalSteps > 0 then track.setAttribute("style", sprintf "grid-template-columns: repeat(%d, 1fr)" historicalSteps.Length) historicalSteps |> Array.iteri (fun i path -> let active = match pinnedIndex with | Some pinned -> pinned = i | None -> i = historicalSteps.Length - 1 track.appendChild (createStepNode (i + 1) path active true (Some i)) |> ignore) else track.setAttribute("style", "grid-template-columns: repeat(3, 1fr)") frames |> Array.iter (fun frame -> track.appendChild (createStepNode frame.Version (sprintf "占位 · %s" frame.Label) false (frame.Version < frames.Length) None) |> ignore) and selectStep (index: int) = if index >= 0 && index < Array.length historicalSteps then stopReplay () applyHistoricalStep index false updateFollowButton () renderTimeline () and createStepNode (version: int) (label: string) (active: bool) (complete: bool) (onClickIndex: int option) = let classes = ResizeArray [ "timeline-step" ] if complete then classes.Add("timeline-step-complete") if onClickIndex.IsSome then classes.Add("timeline-step-real") if active then classes.Add("timeline-step-active") let step = document.createElement("div") step.className <- String.concat " " classes let dot = document.createElement("span") dot.className <- "timeline-dot" dot.setAttribute("aria-hidden", "true") step.appendChild dot |> ignore let versionLabel = document.createElement("span") versionLabel.className <- "timeline-version" versionLabel.textContent <- sprintf "V%02d" version step.appendChild versionLabel |> ignore let text = document.createElement("span") text.className <- "timeline-label" text.textContent <- label step.appendChild text |> ignore match onClickIndex with | Some index -> step.addEventListener("click", fun _ -> selectStep index) | None -> () step let followLatestStep () = match viewState with | Some view when Array.length historicalSteps > 0 -> stopReplay () pinnedIndex <- None let total = Array.length historicalSteps let latest = historicalSteps[total - 1] loadStepArtifact view latest false setText "mesh-label" latest setText "timeline-current" (sprintf "V%02d · 实时跟随 · %s" total latest) setText "replay-state" (sprintf "实时跟随 · 最新 V%02d" total) updateFollowButton () renderTimeline () | _ -> () 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 stopReplay () pinnedIndex <- None historicalSteps <- [||] setText "replay-button" "占位演示" setText "replay-state" "占位示例 · 未选择历史" updateFollowButton () 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, [||] -> if historicalSteps.Length > 0 then stopReplay () historicalSteps <- [||] pinnedIndex <- None setText "replay-button" "占位演示" renderTimeline () updateFollowButton () showFrameMetadata frame renderFrame frame | Some view, steps -> if steps <> historicalSteps then if historicalSteps.Length = 0 then stopReplay () setText "replay-button" "播放历史" historicalSteps <- steps match pinnedIndex with | Some pinned when pinned >= steps.Length -> pinnedIndex <- None | _ -> () renderTimeline () updateFollowButton () match pinnedIndex with | Some _ -> () | None -> let latest = steps[steps.Length - 1] let owner = { ProjectId = payload.projectId RunId = payload.runId Path = latest } if loadedStep <> Some owner then loadStepArtifact view latest false setText "mesh-label" latest setText "timeline-current" (sprintf "V%02d · 实时跟随 · %s" steps.Length latest) setText "replay-state" (sprintf "实时跟随 · 最新 V%02d" steps.Length) | 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 startPlaceholderPlayback () = replayIndex <- 0 setText "replay-button" "暂停占位演示" setText "replay-state" "占位演示中 · 未选择历史" let tick () = if replayIndex >= frames.Length then stopReplay () 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 startHistoricalPlayback () = if Array.length historicalSteps > 0 then setText "replay-button" "暂停历史回放" applyHistoricalStep 0 true updateFollowButton () renderTimeline () let total = Array.length historicalSteps let tick () = match pinnedIndex with | Some pinned when pinned + 1 < total -> applyHistoricalStep (pinned + 1) true renderTimeline () | Some pinned -> stopReplay () setText "replay-button" "播放历史" setText "replay-state" (sprintf "历史回放完成 · 停在 V%02d" (pinned + 1)) | None -> stopReplay () setText "replay-button" "播放历史" replayTimer <- Some(setInterval tick 1500) let toggleReplay () = match replayTimer with | Some handle -> clearInterval handle replayTimer <- None if Array.length historicalSteps > 0 then let current = Option.defaultValue 0 pinnedIndex setText "replay-button" "播放历史" setText "replay-state" (sprintf "历史回放 · 已暂停 · V%02d" (current + 1)) else setText "replay-button" "占位演示" setText "replay-state" "占位演示 · 已暂停" | None -> if Array.length historicalSteps > 0 then startHistoricalPlayback () else startPlaceholderPlayback () 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`` } // The boot run id names a pre-published historical replay that already has an // on-disk manifest; re-running it can only fail ("run directory already // exists"). A user submit keeps their typed ids unless they left the boot // default untouched — then pick a fresh live run id instead. let freshLiveRunId (base_: string) = sprintf "%s-live-%d" base_ (int (JS.Constructors.Date.now () % 1000000.0)) let selectionForLiveStart (selection: RunSelection) = if selection.RunId = "run-probe-real-2" then { selection with RunId = freshLiveRunId selection.RunId } else selection let loadHistoryFor (selection: RunSelection) = let projectId = JS.encodeURIComponent selection.ProjectId let runId = JS.encodeURIComponent selection.RunId let url = sprintf "/api/artifacts/manifest?projectId=%s&runId=%s" projectId runId let requestOptions = createObj [ "method" ==> "GET" ] async { try let! response = fetch (url, requestOptions) |> Async.AwaitPromise if response.ok then let! value = response.json () |> Async.AwaitPromise let payload = value :?> ManifestPayload if payload.status = "complete" && Array.length payload.steps > 0 then let steps = payload.steps |> Array.sortBy (fun step -> step.stepIndex) |> Array.map (fun step -> step.artifactPath) if Array.length steps > 0 then currentProjectId <- selection.ProjectId currentRunId <- selection.RunId historicalSteps <- steps setText "project-id" selection.ProjectId setText "run-id" selection.RunId setText "target-version" (sprintf "V%02d" steps.Length) setText "current-version" (sprintf "V%02d" steps.Length) setText "version-readout" (sprintf "%02d / %02d" steps.Length steps.Length) setWidth "progress-fill" "100%" setText "updated-at" "预发布历史" setText "mesh-label" (sprintf "历史 · %s" steps[steps.Length - 1]) setText "timeline-current" (sprintf "V%02d · 构建重演 · %s" steps.Length steps[steps.Length - 1]) setText "replay-button" "播放历史" setText "replay-state" "构建重演 · 预发布历史" renderTimeline () updateFollowButton () match viewState with | Some view -> loadStepArtifact view steps[steps.Length - 1] true | None -> () with _ -> () } |> Async.StartImmediate 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 已连接" elif response.status = 409 then // The run id already exists on the server. If it completed // earlier, replay its published history instead of treating // the submit as a failure. setText "run-message" "该运行已完成 · 载入历史回放" loadHistoryFor selection else setText "run-message" (sprintf "启动失败 · HTTP %d" response.status) updateStreamState "实时链路 · 启动失败" with _ -> setText "run-message" "启动失败 · 无法连接服务端" updateStreamState "实时链路 · 连接失败" } |> Async.StartImmediate /// Boot-time historical load: surface the pre-published probe build replay so /// first-time visitors see the real vehicle instead of an empty placeholder. /// Any failure leaves the honest placeholder idle state untouched. let loadBootHistory () = loadHistoryFor (selectedRun ()) let boot () = showFrameMetadata frames[0] try initializeView () with _ -> fallbackView () (element "replay-button").addEventListener("click", fun _ -> toggleReplay ()) (element "follow-button").addEventListener("click", fun _ -> followLatestStep ()) (element "viewport-note").addEventListener("click", fun _ -> retryFailedLoad ()) (element "run-controls").addEventListener("submit", fun event -> event.preventDefault() startRun (selectionForLiveStart (selectedRun ()))) loadBootHistory () renderTimeline () boot ()