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: 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 ()