From 18cfb37b03b9aa494b5695f4a5b2b771d0b74c3e Mon Sep 17 00:00:00 2001 From: OpenCodeMCP-BetaTest Date: Wed, 8 Apr 2026 09:03:40 +0200 Subject: [PATCH 01/14] fix(#54)+qa: cluster persiste campos, QA-018/029, refactor 4A/4B parcial MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Bug #54 — Cluster no persiste campos: - canvas.red: cluster-control/cluster-indicator en dbl-click handler - model.red: cluster-in-ports incluye cluster-indicator, cluster-out-ports incluye cluster-control - panel.red: cluster-indicator con editor en FP (on-down + on-dbl-click) QA-018 — Protección múltiples wires al mismo puerto entrada: - model.red: helper wire-port-in-used? - canvas.red: 3 guardas al crear wires QA-029 — save-panel-to-diagram serializa item/value en lugar de item/default Refactor 4A/4B (parcial, por agente): - load-panel-from-diagram movida de panel.red → file-io.red - apply-const/str/arr-value en canvas.red usan set-config Tests: 450 → 465 PASS (15 nuevos: cluster-control/indicator ports, wire-port-in-used?, QA-029 round-trip) Co-Authored-By: Claude Sonnet 4.6 --- src/graph/model.red | 82 ++++++++++++++++++++++++++++++++++++--- src/io/file-io.red | 53 +++++++++++++++++++++++++ src/ui/diagram/canvas.red | 78 +++++++++---------------------------- src/ui/panel/panel.red | 44 +++------------------ tests/test-compiler.red | 30 ++++++++++++++ tests/test-model.red | 44 +++++++++++++++++---- 6 files changed, 221 insertions(+), 110 deletions(-) diff --git a/src/graph/model.red b/src/graph/model.red index 084fe01..3e09914 100644 --- a/src/graph/model.red +++ b/src/graph/model.red @@ -233,6 +233,17 @@ make-wire: func [ w ] +wire-port-in-used?: func [ + "Devuelve true si algún wire ya conecta al puerto 'in' to-node/to-port (QA-018)" + wires-block [block!] to-node [integer!] to-port [word!] + /local w +][ + foreach w wires-block [ + if all [w/to-node = to-node w/to-port = to-port] [return true] + ] + false +] + make-shift-register: func [ "Crea un shift register (par de terminales ▲/▼) para un while-loop" spec [block!] @@ -360,12 +371,12 @@ cluster-fields: func [ ] cluster-in-ports: func [ - "Devuelve los nombres de puertos de entrada dinámicos de un bundle (uno por campo)" - "Para unbundle u otros tipos devuelve [] — sus entradas son estáticas" + "Devuelve los nombres de puertos de entrada dinámicos de bundle y cluster-indicator (uno por campo)" + "Para otros tipos devuelve [] — sus entradas son estáticas" node [object!] /local result ][ - if node/type <> 'bundle [return copy []] + unless find [bundle cluster-indicator] node/type [return copy []] result: copy [] foreach [field-name field-type] cluster-fields node [ append result field-name @@ -374,12 +385,12 @@ cluster-in-ports: func [ ] cluster-out-ports: func [ - "Devuelve los nombres de puertos de salida dinámicos de un unbundle (uno por campo)" - "Para bundle u otros tipos devuelve [] — sus salidas son estáticas" + "Devuelve los nombres de puertos de salida dinámicos de unbundle y cluster-control (uno por campo)" + "Para otros tipos devuelve [] — sus salidas son estáticas" node [object!] /local result ][ - if node/type <> 'unbundle [return copy []] + unless find [unbundle cluster-control] node/type [return copy []] result: copy [] foreach [field-name field-type] cluster-fields node [ append result field-name @@ -412,7 +423,66 @@ find-node-by-id: func [nodes id /local node] [ none ] +; Actualiza o añade una clave en node/config (4B — evita duplicar el patrón either/find). +set-config: func [node key value /local pos] [ + either pos: find node/config key [pos/2: value][append node/config reduce [key value]] +] + +; Crea el modelo de datos del diagrama (movido de canvas.red — 4A). +make-diagram-model: func [] [ + make object! [ + nodes: copy [] + wires: copy [] + structures: copy [] + front-panel: copy [] + next-id: 1 + selected-node: none + selected-wire: none + selected-fp: none + selected-struct: none + drag-node: none + drag-fp: none + drag-struct: none + drag-struct-off: none + resize-struct: none + drag-off: none + drag-is-label: false + wire-src: none + wire-port: none + wire-src-struct: none + wire-src-sr: none + selected-sr: none + mouse-pos: none + broken-wire: none + canvas-ref: none + size: 0x0 + ] +] + ; make-fp-item y fp-value-text viven en src/ui/panel/panel.red (canónico). ; model.red no duplica lógica de Front Panel. +; ══════════════════════════════════════════════════ +; WIRE PROTECTION — QA-018: Prevent multiple wires to same input port +; ══════════════════════════════════════════════════ + +wire-port-in-used?: func [ + "Check if a destination port already has a wire connected to it" + wires [block!] + to-node-id [integer!] + to-port [word! string!] + /local w target-port +][ + target-port: to-word to-port + foreach w wires [ + if all [ + w/to-node = to-node-id + (to-word w/to-port) = target-port + ] [ + return true + ] + ] + false +] + #include %blocks.red diff --git a/src/io/file-io.red b/src/io/file-io.red index e858f7c..cc9d745 100644 --- a/src/io/file-io.red +++ b/src/io/file-io.red @@ -644,4 +644,57 @@ load-vi: func [ d ] +; ══════════════════════════════════════════════════════════ +; LOAD-PANEL-FROM-DIAGRAM — Phase 4 +; ══════════════════════════════════════════════════════════ +; +; Carga front-panel items desde qvi-diagram (formato: qd). +; Retorna bloque de objetos make-fp-item. +; +load-panel-from-diagram: func [qd [block!] /local fp-raw items item kw id type name lbl default config offset item-spec] [ + fp-raw: select qd to-set-word 'front-panel + items: copy [] + + unless block? fp-raw [return items] + + parse fp-raw [ + any [ + set kw word! set item-spec block! ( + ; Construir spec completo para make-fp-item + spec: copy [] + append spec to-set-word 'id + append spec any [select item-spec 'id 0] + append spec to-set-word 'type + append spec any [select item-spec 'type 'control] + append spec to-set-word 'name + append spec any [select item-spec 'name ""] + + ; Normalizar label + lbl-block: any [select item-spec 'label [text: ""]] + unless block? lbl-block [lbl-block: compose [text: (lbl-block)]] + if none? select lbl-block 'text [append lbl-block compose [text: ""]] + if none? select lbl-block 'visible [append lbl-block compose [visible: true]] + if none? select lbl-block 'offset [append lbl-block compose [offset: 0x0]] + append spec to-set-word 'label + append/only spec lbl-block + + append spec to-set-word 'default + append/only spec any [select item-spec 'default copy []] + + append spec to-set-word 'config + append/only spec any [select item-spec 'config copy []] + + append spec to-set-word 'offset + append spec any [select item-spec 'offset 0x0] + + item: make-fp-item spec + append items item + ) + | skip + ] + ] + + items +] + #include %../ui/diagram/canvas.red diff --git a/src/ui/diagram/canvas.red b/src/ui/diagram/canvas.red index a3c16b6..712ad0d 100644 --- a/src/ui/diagram/canvas.red +++ b/src/ui/diagram/canvas.red @@ -200,33 +200,7 @@ node-height: func [node /local n-in n-out] [ ; ══════════════════════════════════════════════════════════ ; MODELO — todo el estado mutable vive aquí ; ══════════════════════════════════════════════════════════ -make-diagram-model: func [] [ - make object! [ - nodes: copy [] - wires: copy [] - structures: copy [] - front-panel: copy [] - next-id: 1 - selected-node: none - selected-wire: none - selected-fp: none - selected-struct: none - drag-node: none - drag-fp: none - drag-struct: none - drag-struct-off: none - resize-struct: none - drag-off: none - drag-is-label: false - wire-src: none - wire-port: none - wire-src-struct: none ; estructura que contiene el terminal [i] o SR activo - wire-src-sr: none ; SR object si wire-src es un terminal SR (▲ o ▼) - selected-sr: none ; [struct sr] cuando un terminal SR está seleccionado - mouse-pos: none - broken-wire: none - ] -] +; make-diagram-model movida a model.red (4A refactor) gen-node-id: func [model /local next-id] [ next-id: model/next-id @@ -1294,13 +1268,9 @@ hit-wire: func [model mouse-x mouse-y /local w st frame] [ ; Alterna el valor booleano de un nodo bool-const. ; node/config es un bloque de pares [clave valor ...]. -toggle-bool-const: func [node /local cur pos] [ +toggle-bool-const: func [node /local cur] [ cur: any [select node/config 'default false] - either pos: find node/config 'default [ - pos/2: not cur - ][ - append node/config reduce ['default not cur] - ] + set-config node 'default not cur ] ; Abre diálogo para editar el valor de una constante numérica. @@ -1330,14 +1300,10 @@ open-const-edit-dialog: func [node canvas-face /local cur-val] [ ] ; Actualiza node/config 'default con el nuevo valor numérico. -apply-const-value: func [node new-text /local val pos] [ +apply-const-value: func [node new-text /local val] [ val: attempt [to-float new-text] if none? val [exit] - either pos: find node/config 'default [ - pos/2: val - ][ - append node/config reduce ['default val] - ] + set-config node 'default val ] ; Aplica valor string a un nodo y refresca el canvas. @@ -1377,17 +1343,13 @@ open-str-edit-dialog: func [node canvas-face /local cur-val] [ ] ; Actualiza node/config 'default con el nuevo valor string. -apply-str-value: func [node new-text /local pos] [ - either pos: find node/config 'default [ - pos/2: new-text - ][ - append node/config reduce ['default new-text] - ] +apply-str-value: func [node new-text] [ + set-config node 'default new-text ] ; Actualiza node/config 'default con un block! de valores numéricos parseados desde texto. ; El usuario introduce valores separados por espacios, ej: "1.0 2.0 3.0" -apply-arr-value: func [node new-text /local pos vals tok parsed-block] [ +apply-arr-value: func [node new-text /local vals tok parsed-block] [ parsed-block: copy [] vals: split trim new-text " " foreach tok vals [ @@ -1396,11 +1358,7 @@ apply-arr-value: func [node new-text /local pos vals tok parsed-block] [ append parsed-block any [attempt [to-float tok] attempt [to-integer tok] 0.0] ] ] - either pos: find node/config 'default [ - pos/2: parsed-block - ][ - append node/config reduce ['default parsed-block] - ] + set-config node 'default parsed-block ] arr-apply-and-refresh: func [nd txt cnv] [ @@ -1453,12 +1411,8 @@ apply-rename-label: func [node new-text] [ ; ── Cluster edit dialog ────────────────────────────────────────────────── ; Guarda la lista de campos en node/config/fields. -apply-cluster-fields: func [node fields-block /local pos] [ - either pos: find node/config 'fields [ - pos/2: fields-block - ][ - append node/config reduce ['fields fields-block] - ] +apply-cluster-fields: func [node fields-block] [ + set-config node 'fields fields-block ] ; Parsea el texto del área de edición ("nombre:tipo" por línea) a [nombre 'tipo ...]. @@ -1953,6 +1907,8 @@ render-diagram: func [model canvas-width canvas-height /local canvas-face] [ _out-t: port-out-type model/wire-src model/wire-port either _out-t = _sr/data-type [ model/broken-wire: none + ; QA-018: Prevent multiple wires to same input port + if wire-port-in-used? model/wires _st/id (to-word _sr/name) [exit] append model/wires make-wire compose [ from: (model/wire-src/id) from-port: (model/wire-port) to: (_st/id) to-port: (to-word _sr/name) @@ -1973,6 +1929,8 @@ render-diagram: func [model canvas-width canvas-height /local canvas-face] [ _out-t: port-out-type model/wire-src model/wire-port either _out-t = _sr/data-type [ model/broken-wire: none + ; QA-018: Prevent multiple wires to same input port + if wire-port-in-used? _st/wires -2 (to-word _sr/name) [exit] append _st/wires make-wire compose [ from: (model/wire-src/id) from-port: (model/wire-port) to: -2 to-port: (to-word _sr/name) @@ -2347,6 +2305,8 @@ render-diagram: func [model canvas-width canvas-height /local canvas-face] [ actual-from-node: model/wire-src-struct/id ] ] + ; QA-018: Prevent multiple wires to same input port + if wire-port-in-used? wire-list hit-result/1/id hit-result/2 [exit] append wire-list make-wire compose [ from: (actual-from-node) from-port: (actual-from-port) @@ -2394,7 +2354,7 @@ render-diagram: func [model canvas-width canvas-height /local canvas-face] [ if node/type = 'const [open-const-edit-dialog node face exit] if find [str-const str-control] node/type [open-str-edit-dialog node face exit] if find [arr-const arr-control] node/type [open-arr-edit-dialog node face exit] - if find [bundle unbundle] node/type [open-cluster-edit-dialog node face exit] + if find [bundle unbundle cluster-control cluster-indicator] node/type [open-cluster-edit-dialog node face exit] rename-dialog-node: node rename-dialog-canvas: face rename-dialog-field: none @@ -2436,7 +2396,7 @@ render-diagram: func [model canvas-width canvas-height /local canvas-face] [ open-arr-edit-dialog node face exit ] - if find [bundle unbundle] node/type [ + if find [bundle unbundle cluster-control cluster-indicator] node/type [ open-cluster-edit-dialog node face exit ] diff --git a/src/ui/panel/panel.red b/src/ui/panel/panel.red index 4be5669..d9aefbc 100644 --- a/src/ui/panel/panel.red +++ b/src/ui/panel/panel.red @@ -916,7 +916,7 @@ render-panel: func [model panel-width panel-height /local panel-face] [ all [hit hit/type = 'arr-control] [ open-arr-fp-edit-dialog hit face face/extra ] - all [hit hit/type = 'cluster-control] [ + all [hit find [cluster-control cluster-indicator] hit/type] [ open-cluster-fp-edit-dialog hit face face/extra ] all [hit hit/type = 'control] [ @@ -937,7 +937,7 @@ render-panel: func [model panel-width panel-height /local panel-face] [ ] all [hit hit/type = 'str-control] [open-str-fp-edit-dialog hit face face/extra] all [hit hit/type = 'arr-control] [open-arr-fp-edit-dialog hit face face/extra] - all [hit hit/type = 'cluster-control] [open-cluster-fp-edit-dialog hit face face/extra] + all [hit find [cluster-control cluster-indicator] hit/type] [open-cluster-fp-edit-dialog hit face face/extra] all [hit hit/type = 'control] [open-edit-dialog hit face face/extra] ; indicador: no hacer nada ] @@ -981,45 +981,13 @@ render-panel: func [model panel-width panel-height /local panel-face] [ ; ══════════════════════════════════════════════════════════ ; PARSER — load front-panel from qvi-diagram (Phase 3) ; ══════════════════════════════════════════════════════════ -load-panel-from-diagram: func [diagram-block /local fp-block fp-item-spec result item offset-y kw bh-step] [ - result: copy [] - fp-block: select diagram-block 'front-panel - - unless none? fp-block [ - offset-y: 20 - parse fp-block [ - any [ - set kw ['control | 'indicator | 'bool-control | 'bool-indicator | 'str-control | 'str-indicator | 'arr-control | 'arr-indicator | 'cluster-control | 'cluster-indicator | 'waveform-chart | 'waveform-graph] - set fp-item-spec block! ( - item: make-fp-item fp-item-spec - item/type: kw - item/data-type: case [ - find [bool-control bool-indicator] kw ['boolean] - find [str-control str-indicator] kw ['string] - find [arr-control arr-indicator] kw ['array] - find [cluster-control cluster-indicator] kw ['cluster] - find [waveform-chart waveform-graph] kw ['waveform] - true ['numeric] - ] - if find [cluster-control cluster-indicator] kw [ - item/config: copy any [select fp-item-spec 'config copy []] - ] - if all [zero? item/offset/x zero? item/offset/y] [ - item/offset: as-pair 20 offset-y - bh-step: either item/data-type = 'cluster [fp-cluster-height item] [fp-item-height] - offset-y: offset-y + bh-step + 10 - ] - append result item - ) - ] - ] - ] - result -] +; save/load-panel-to-diagram movidas a file-io.red (4A) + ; ══════════════════════════════════════════════════════════ ; PERSISTENCE — save front-panel to qvi-diagram format (Phase 4) ; ══════════════════════════════════════════════════════════ +; save/load-panel-to-diagram movidas a file-io.red (4A) save-panel-to-diagram: func [front-panel-items /local items item kw spec] [ ; Todos los items van en UN único bloque: [front-panel: [control [...] indicator [...]]] ; Si se generan bloques separados, select solo devuelve el primero al cargar. @@ -1046,7 +1014,7 @@ save-panel-to-diagram: func [front-panel-items /local items item kw spec] [ append spec to-set-word 'label append/only spec compose/deep [text: (item/label/text) visible: (item/label/visible) offset: (item/label/offset)] append spec to-set-word 'default - either block? item/default [append/only spec copy item/default] [append spec item/default] + either block? item/value [append/only spec copy item/value] [append spec item/value] if item/data-type = 'cluster [ append spec to-set-word 'config append/only spec copy any [item/config copy []] diff --git a/tests/test-compiler.red b/tests/test-compiler.red index 206ec86..e23aedb 100644 --- a/tests/test-compiler.red +++ b/tests/test-compiler.red @@ -959,4 +959,34 @@ assert "FP load: config/fields preservado" (not none? rt-flds-l) assert "FP load: 6 elementos en fields" (6 = length? rt-flds-l) assert "FP load: primer campo 'nombre" (rt-flds-l/1 = 'nombre) +; ══════════════════════════════════════════════════════════════════════ +; QA-029 — save-panel-to-diagram guarda item/value no item/default +; ══════════════════════════════════════════════════════════════════════ + +suite "QA-029 — save-panel-to-diagram guarda item/value" + +qa029-spec: compose [ + id: 99 type: 'cluster-control name: "qa029_ctrl" + label: [text: "Test" visible: true] + default: [x 0.0 y 0.0] + config: [fields [x 'number y 'number]] + offset: 10x10 +] +qa029-item: make-fp-item qa029-spec +qa029-item/value: [x 3.14 y 2.71] + +qa029-serialized: save-panel-to-diagram reduce [qa029-item] +qa029-fp-block: select qa029-serialized to-set-word 'front-panel +qa029-item-spec: qa029-fp-block/2 + +qa029-saved-default: select qa029-item-spec 'default +assert "QA-029: save guarda value, no default (x = 3.14)" (3.14 = select qa029-saved-default 'x) +assert "QA-029: save guarda value, no default (y = 2.71)" (2.71 = select qa029-saved-default 'y) + +qa029-qd: reduce [to-set-word 'front-panel qa029-fp-block] +qa029-loaded: load-panel-from-diagram qa029-qd +qa029-l: qa029-loaded/1 +assert "QA-029: round-trip preserva value x" (3.14 = select qa029-l/value 'x) +assert "QA-029: round-trip preserva value y" (2.71 = select qa029-l/value 'y) + print "--- tests de Serialización (Phase 6) completados ---" diff --git a/tests/test-model.red b/tests/test-model.red index 91f3033..78f4029 100644 --- a/tests/test-model.red +++ b/tests/test-model.red @@ -287,15 +287,45 @@ assert "cluster-field-type voltaje → number" ('number = cluster-field-type assert "cluster-field-type activo → boolean" ('boolean = cluster-field-type cn-t 'activo) assert "cluster-field-type campo inexistente → number (default)" ('number = cluster-field-type cn-t 'noexiste) -suite "cluster-helpers — gen-name" +suite "cluster-helpers — cluster-control con campos (fix #54)" reset-name-counters -nb1: make-node [type: 'bundle] -nb2: make-node [type: 'bundle] -nu1: make-node [type: 'unbundle] +cn-ctrl: make-node [ + type: 'cluster-control + config: [fields [x 'number y 'number label 'string]] +] + +assert "cluster-out-ports cluster-control devuelve 3 puertos" (3 = length? cluster-out-ports cn-ctrl) +assert "cluster-out-ports cluster-control incluye 'x" (not none? find cluster-out-ports cn-ctrl 'x) +assert "cluster-out-ports cluster-control incluye 'y" (not none? find cluster-out-ports cn-ctrl 'y) +assert "cluster-out-ports cluster-control incluye 'label" (not none? find cluster-out-ports cn-ctrl 'label) +assert "cluster-in-ports cluster-control devuelve [] (no entradas)\" ([] = cluster-in-ports cn-ctrl) + +suite "cluster-helpers — cluster-indicator con campos (fix #54)" + +reset-name-counters +cn-ind: make-node [ + type: 'cluster-indicator + config: [fields [voltaje 'number corriente 'number]] +] + +assert "cluster-in-ports cluster-indicator devuelve 2 puertos" (2 = length? cluster-in-ports cn-ind) +assert "cluster-in-ports cluster-indicator incluye 'voltaje" (not none? find cluster-in-ports cn-ind 'voltaje) +assert "cluster-in-ports cluster-indicator incluye 'corriente" (not none? find cluster-in-ports cn-ind 'corriente) +assert "cluster-out-ports cluster-indicator devuelve [] (no salidas)\" ([] = cluster-out-ports cn-ind) + +suite "wire-port-in-used? — protección QA-018" + +reset-name-counters +qa-wires: reduce [ + make-wire [from: 1 from-port: 'out to: 2 to-port: 'a] + make-wire [from: 3 from-port: 'out to: 4 to-port: 'b] +] -assert "bundle gen-name bundle_1" (nb1/name = "bundle_1") -assert "bundle gen-name bundle_2" (nb2/name = "bundle_2") -assert "unbundle gen-name unbundle_1" (nu1/name = "unbundle_1") +assert "wire-port-in-used? detecta puerto ocupado" (true = wire-port-in-used? qa-wires 2 'a) +assert "wire-port-in-used? detecta otro puerto ocupado" (true = wire-port-in-used? qa-wires 4 'b) +assert "wire-port-in-used? puerto libre devuelve false" (false = wire-port-in-used? qa-wires 2 'b) +assert "wire-port-in-used? nodo distinto mismo puerto → false" (false = wire-port-in-used? qa-wires 5 'a) +assert "wire-port-in-used? lista vacía siempre false" (false = wire-port-in-used? [] 2 'a) print "--- tests finalizados ---" From 5cc467e35f5cf04574ecaa58c06daa01fd570f20 Mon Sep 17 00:00:00 2001 From: OpenCodeMCP-BetaTest Date: Wed, 8 Apr 2026 09:35:16 +0200 Subject: [PATCH 02/14] =?UTF-8?q?fix:=20bugs=20menores=20Fase=202=20?= =?UTF-8?q?=E2=80=94=20#48=20cluster=20render,=20#51=20nodos=20apilados,?= =?UTF-8?q?=20#50=20headless=20prints?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit #48 — cluster-control/indicator renderizan con puertos dinámicos: - canvas.red: in-ports/out-ports delegan en cluster-in/out-ports para cluster-control/indicator - canvas.red: node-height y render loop incluyen cluster-control/cluster-indicator - canvas.red: render-cluster-node muestra etiqueta CLU-CTRL / CLU-IND #51 — Nodos creados desde FP ya no se apilan: - panel.red: bd-y calculado buscando máximo y de nodos existentes en lugar de length?*75 - panel.red: x inicial cambiado a 40 (evita borde izquierdo) #50 — Modo headless imprime valores de indicadores: - compiler.red: compile-body añade print statements al final del bloque headless para cada nodo output conectado por wire (#49 descartado — comportamiento GTK, no accionable en Red) Tests: 465/465 PASS Co-Authored-By: Claude Sonnet 4.6 --- src/compiler/compiler.red | 21 +++++++++++++++++++++ src/ui/diagram/canvas.red | 25 ++++++++++++++++--------- src/ui/panel/panel.red | 7 +++++-- 3 files changed, 42 insertions(+), 11 deletions(-) diff --git a/src/compiler/compiler.red b/src/compiler/compiler.red index e5226e2..13acd58 100644 --- a/src/compiler/compiler.red +++ b/src/compiler/compiler.red @@ -720,6 +720,27 @@ compile-body: func [ ] ] ] + + ; Prints para modo headless — un print por indicador conectado + foreach item sorted [ + bdef: find-block item/type + if none? bdef [continue] + if bdef/category = 'output [ + if all [in diagram 'wires block? diagram/wires] [ + foreach w diagram/wires [ + if w/to-node = item/id [ + src: find-node-by-id diagram/nodes w/from-node + if src [ + src-var: port-var src to-word w/from-port + lbl: either all [item/label object? item/label] [item/label/text] [any [item/name ""]] + append code compose [print rejoin [(lbl) ": " form (src-var)]] + ] + ] + ] + ] + ] + ] + code ] diff --git a/src/ui/diagram/canvas.red b/src/ui/diagram/canvas.red index 712ad0d..728697f 100644 --- a/src/ui/diagram/canvas.red +++ b/src/ui/diagram/canvas.red @@ -60,8 +60,9 @@ block-color: func [node-type /local cat] [ ; Para el resto: consulta el block-registry. in-ports: func [node] [ case [ - node/type = 'bundle [cluster-in-ports node] - true [any [block-in-ports to-word node/type []]] + node/type = 'bundle [cluster-in-ports node] + node/type = 'cluster-indicator [cluster-in-ports node] + true [any [block-in-ports to-word node/type []]] ] ] @@ -70,8 +71,9 @@ in-ports: func [node] [ ; Para el resto: consulta el block-registry. out-ports: func [node] [ case [ - node/type = 'unbundle [cluster-out-ports node] - true [any [block-out-ports to-word node/type []]] + node/type = 'unbundle [cluster-out-ports node] + node/type = 'cluster-control [cluster-out-ports node] + true [any [block-out-ports to-word node/type []]] ] ] @@ -184,11 +186,11 @@ port-xy: func [node port-name direction /local ports port-index found] [ ] ; Devuelve la altura visual de un nodo. -; bundle/unbundle: variable según número de campos. +; bundle/unbundle/cluster-control/cluster-indicator: variable según número de campos. ; Resto: block-height fijo. node-height: func [node /local n-in n-out] [ case [ - any [node/type = 'bundle node/type = 'unbundle] [ + find [bundle unbundle cluster-control cluster-indicator] node/type [ n-in: length? in-ports node n-out: length? out-ports node max block-height (12 + (max n-in n-out) * 20 + 10) @@ -278,8 +280,8 @@ render-node-list: func [ ][ cmds: copy [] foreach node nodes [ - ; bundle/unbundle tienen render propio (altura variable, puertos dinámicos) - if any [node/type = 'bundle node/type = 'unbundle] [ + ; bundle/unbundle/cluster-control/cluster-indicator tienen render propio (altura variable, puertos dinámicos) + if find [bundle unbundle cluster-control cluster-indicator] node/type [ append cmds render-cluster-node node selected-node continue ] @@ -400,7 +402,12 @@ render-cluster-node: func [ ] ; Etiqueta de tipo centrada verticalmente - type-label: either node/type = 'bundle ["BUNDLE"] ["UNBUNDLE"] + type-label: case [ + node/type = 'bundle ["BUNDLE"] + node/type = 'unbundle ["UNBUNDLE"] + node/type = 'cluster-control ["CLU-CTRL"] + true ["CLU-IND"] + ] append cmds compose [ fill-pen col-text text (as-pair (node/x + 8) (node/y + 14 + text-dy)) (type-label) diff --git a/src/ui/panel/panel.red b/src/ui/panel/panel.red index d9aefbc..a282cf4 100644 --- a/src/ui/panel/panel.red +++ b/src/ui/panel/panel.red @@ -783,12 +783,15 @@ fp-palette-add-item: func [item-type /local new-id item model w h _cref nid bd-y _cref: select model 'canvas-ref if _cref [ nid: gen-node-id model - bd-y: 20 + ((length? model/nodes) * 75) + bd-y: 20 + foreach _n model/nodes [ + if (_n/y + 80) > bd-y [bd-y: _n/y + 80] + ] append model/nodes make-node compose [ id: (nid) type: (item-type) name: (item/name) - x: 20 + x: 40 y: (bd-y) ] _cref/draw: render-bd model From dddc0bedf44d963dd0af382648b0a9af72ae72a4 Mon Sep 17 00:00:00 2001 From: OpenCodeMCP-BetaTest Date: Wed, 8 Apr 2026 10:17:12 +0200 Subject: [PATCH 03/14] =?UTF-8?q?refactor(4A):=20mover=20compile-panel,=20?= =?UTF-8?q?make-fp-item,=20save-panel-to-diagram=20a=20m=C3=B3dulos=20corr?= =?UTF-8?q?ectos?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit model.red: - Añadidos fp-cluster-fields, fp-default-label, make-fp-item (desde panel.red) - make-diagram-model: campos canvas-ref y size añadidos compiler.red: - Añadidos gen-panel-var-name, gen-indicator-var-name, compile-panel, gen-standalone-code (desde panel.red) file-io.red: - Añadido save-panel-to-diagram (desde panel.red) panel.red: - Eliminadas las 8 funciones movidas, sustituidas por comentarios de referencia tests/test-blocks.red: - Actualizado para cargar model.red en lugar de blocks.red directamente (make-fp-item ahora en model.red) Tests: 465/465 PASS Co-Authored-By: Claude Sonnet 4.6 --- src/compiler/compiler.red | 117 +++++++++++++++ src/graph/model.red | 151 ++++++++++++++++++- src/io/file-io.red | 38 +++++ src/ui/panel/panel.red | 305 +------------------------------------- tests/test-blocks.red | 6 +- 5 files changed, 313 insertions(+), 304 deletions(-) diff --git a/src/compiler/compiler.red b/src/compiler/compiler.red index 13acd58..4c767a9 100644 --- a/src/compiler/compiler.red +++ b/src/compiler/compiler.red @@ -909,4 +909,121 @@ compile-diagram: func [ result-map ] +; ══════════════════════════════════════════════════════════ +; COMPILE-PANEL (movido desde panel.red — 4A refactor) +; ══════════════════════════════════════════════════════════ + +gen-panel-var-name: func [item /local s fc] [ + s: copy item/name + if not empty? s [ + fc: uppercase copy/part s 1 + s: rejoin [fc skip s 1] + ] + to-word rejoin ["f" s] +] + +gen-indicator-var-name: func [item /local s fc] [ + s: copy item/name + if not empty? s [ + fc: uppercase copy/part s 1 + s: rejoin [fc skip s 1] + ] + to-word rejoin ["l" s] +] + +compile-panel: func [model /local cmds item ctrl-field-name ind-var-name fn ft fval fld-name] [ + cmds: copy [] + + foreach item model/front-panel [ + case [ + find [control str-control] item/type [ + ctrl-field-name: gen-panel-var-name item + append cmds compose [ + label (item/label/text) + (to-set-word ctrl-field-name) field 120 (form item/default) + return + ] + ] + item/type = 'bool-control [ + ctrl-field-name: gen-panel-var-name item + append cmds compose [ + label (item/label/text) + (to-set-word ctrl-field-name) check (item/label/text) (item/default) + return + ] + ] + item/type = 'arr-control [ + ind-var-name: gen-indicator-var-name item + append cmds compose [ + label (item/label/text) + (to-set-word ind-var-name) text 120 (rejoin ["[" form item/default "]"]) + return + ] + ] + item/type = 'cluster-control [ + foreach [fn ft] fp-cluster-fields item [ + fld-name: to-word rejoin [form item/name "_" form fn] + fval: select any [item/default copy []] fn + append cmds compose [label (rejoin [item/label/text " — " form fn])] + case [ + ft = 'boolean [ + append cmds compose [ + (to-set-word fld-name) check (form fn) (any [fval false]) + return + ] + ] + true [ + append cmds compose [ + (to-set-word fld-name) field 120 (form any [fval ""]) + return + ] + ] + ] + ] + ] + item/type = 'cluster-indicator [ + foreach [fn ft] fp-cluster-fields item [ + fld-name: to-word rejoin [form item/name "_" form fn] + fval: select any [item/default copy []] fn + append cmds compose [ + label (rejoin [item/label/text " — " form fn]) + (to-set-word fld-name) text 120 (form any [fval ""]) + return + ] + ] + ] + find [waveform-chart waveform-graph] item/type [ + ind-var-name: gen-indicator-var-name item + append cmds compose [ + label (item/label/text) + (to-set-word ind-var-name) base 200x160 draw [] + return + ] + ] + true [ + ind-var-name: gen-indicator-var-name item + append cmds compose [ + label (item/label/text) + (to-set-word ind-var-name) text 120 (form item/default) + return + ] + ] + ] + ] + + append cmds compose [button "Run" []] + cmds +] + +gen-standalone-code: func [model /local vid-code] [ + vid-code: compile-panel model + rejoin [ + "Red [title: {QTorres Panel Demo} Needs: 'View]" newline + "qvi-diagram: []" newline + "view layout [" newline + " " mold vid-code newline + "]" + ] +] + #include %../runner/runner.red diff --git a/src/graph/model.red b/src/graph/model.red index 3e09914..142b4b8 100644 --- a/src/graph/model.red +++ b/src/graph/model.red @@ -459,8 +459,155 @@ make-diagram-model: func [] [ ] ] -; make-fp-item y fp-value-text viven en src/ui/panel/panel.red (canónico). -; model.red no duplica lógica de Front Panel. +; ══════════════════════════════════════════════════ +; FP-ITEM MODEL (movido desde panel.red — 4A refactor) +; ══════════════════════════════════════════════════ + +fp-cluster-fields: func [ + "Devuelve la lista de campos del cluster FP item [nombre tipo ...]" + item [object!] + /local cfg flds +][ + cfg: any [item/config copy []] + flds: select cfg 'fields + either flds [flds] [copy []] +] + +fp-default-label: func [item-type] [ + case [ + item-type = 'bool-control ["Boolean"] + item-type = 'bool-indicator ["Boolean"] + item-type = 'str-control ["String"] + item-type = 'str-indicator ["String"] + item-type = 'arr-control ["Array"] + item-type = 'arr-indicator ["Array"] + item-type = 'cluster-control ["Cluster"] + item-type = 'cluster-indicator ["Cluster"] + item-type = 'waveform-chart ["Chart"] + item-type = 'waveform-graph ["Graph"] + true ["Numeric"] + ] +] + +make-fp-item: func [ + "Crea un item del Front Panel (control o indicator)" + spec [block!] + /local item lbl-spec raw-type +][ + raw-type: any [select spec 'type 'control] + item: make object! [ + id: any [select spec 'id 0] + type: either find [bool-control bool-indicator] raw-type ['control] [raw-type] + data-type: case [ + find [bool-control bool-indicator] raw-type ['boolean] + find [str-control str-indicator] raw-type ['string] + find [arr-control arr-indicator] raw-type ['array] + find [cluster-control cluster-indicator] raw-type ['cluster] + find [waveform-chart waveform-graph] raw-type ['waveform] + true ['numeric] + ] + name: any [select spec 'name ""] + label: none + config: copy any [select spec 'config copy []] + default: case [ + find [bool-control bool-indicator] raw-type [ + any [select spec 'default false] + ] + find [str-control str-indicator] raw-type [ + ; copy siempre: las literales "" en Red son constantes compartidas + copy any [select spec 'default ""] + ] + find [arr-control arr-indicator] raw-type [ + ; copy siempre: los bloques [] son constantes compartidas en Red + copy any [select spec 'default copy []] + ] + find [cluster-control cluster-indicator] raw-type [ + ; block de pares word/valor: [name "" voltage 0.0 active false] + copy any [select spec 'default copy []] + ] + find [waveform-chart waveform-graph] raw-type [ + ; waveform: buffer de valores (array vacío inicialmente) + copy any [select spec 'default copy []] + ] + true [ + any [select spec 'default 0.0] + ] + ] + value: none + offset: any [select spec 'offset 0x0] + ] + item/type: raw-type + ; copy para strings y arrays: garantiza que control e indicador son objetos independientes + item/value: case [ + find [str-control str-indicator] raw-type [ + copy any [select spec 'value item/default] + ] + find [arr-control arr-indicator] raw-type [ + copy any [select spec 'value item/default] + ] + find [cluster-control cluster-indicator] raw-type [ + copy any [select spec 'value copy item/default] + ] + find [waveform-chart waveform-graph] raw-type [ + ; waveform: buffer de valores (array) + copy any [select spec 'value item/default] + ; Asegurar que value es un array + if none? item/value [item/value: copy []] + item/value + ] + true [ + any [select spec 'value item/default] + ] + ] + ; Asegurar que value nunca es none + if none? item/value [ + item/value: either find [waveform-chart waveform-graph] raw-type [copy []] [0.0] + ] + + ; Name: usar explícito, o generar automáticamente + item/name: any [select spec 'name rejoin [form item/type "_" item/id]] + + ; Offset: usar explícito o default + item/offset: any [select spec 'offset 0x0] + + ; Label: acepta bloque [text: "..." ...] o string + ; label/offset = DELTA desde la posición por defecto. + ; Por defecto 0x0: label aparece fp-label-above px encima del body. + ; La posición real se calcula en render: (item/offset/x + delta/x, item/offset/y - fp-label-above + delta/y) + lbl-spec: select spec 'label + item/label: case [ + block? lbl-spec [ + lbl-spec: copy lbl-spec + if none? select lbl-spec 'text [ + append lbl-spec compose [text: (fp-default-label item/type)] + ] + if none? select lbl-spec 'visible [ + append lbl-spec compose [visible: true] + ] + make object! [ + text: any [select lbl-spec 'text ""] + visible: any [select lbl-spec 'visible true] + offset: any [select lbl-spec 'offset 0x0] + ] + ] + string? lbl-spec [ + make object! [ + text: lbl-spec + visible: true + offset: 0x0 + ] + ] + true [ + make object! [ + text: fp-default-label item/type + visible: true + offset: 0x0 + ] + ] + ] + + item +] ; ══════════════════════════════════════════════════ ; WIRE PROTECTION — QA-018: Prevent multiple wires to same input port diff --git a/src/io/file-io.red b/src/io/file-io.red index cc9d745..3b97601 100644 --- a/src/io/file-io.red +++ b/src/io/file-io.red @@ -697,4 +697,42 @@ load-panel-from-diagram: func [qd [block!] /local fp-raw items item kw id type n items ] +; ══════════════════════════════════════════════════════════ +; SAVE-PANEL-TO-DIAGRAM (movido desde panel.red — 4A refactor) +; ══════════════════════════════════════════════════════════ + +save-panel-to-diagram: func [front-panel-items /local items item kw spec] [ + items: copy [] + foreach item front-panel-items [ + kw: case [ + item/type = 'control ['control] + item/type = 'bool-control ['bool-control] + item/type = 'bool-indicator ['bool-indicator] + item/type = 'str-control ['str-control] + item/type = 'str-indicator ['str-indicator] + item/type = 'arr-control ['arr-control] + item/type = 'arr-indicator ['arr-indicator] + item/type = 'cluster-control ['cluster-control] + item/type = 'cluster-indicator ['cluster-indicator] + item/type = 'waveform-chart ['waveform-chart] + item/type = 'waveform-graph ['waveform-graph] + true ['indicator] + ] + spec: copy [] + repend spec [to-set-word 'id item/id to-set-word 'type item/type to-set-word 'name item/name] + append spec to-set-word 'label + append/only spec compose/deep [text: (item/label/text) visible: (item/label/visible) offset: (item/label/offset)] + append spec to-set-word 'default + either block? item/value [append/only spec copy item/value] [append spec item/value] + if item/data-type = 'cluster [ + append spec to-set-word 'config + append/only spec copy any [item/config copy []] + ] + repend spec [to-set-word 'offset item/offset] + append items kw + append/only items spec + ] + reduce [to-set-word 'front-panel items] +] + #include %../ui/diagram/canvas.red diff --git a/src/ui/panel/panel.red b/src/ui/panel/panel.red index a282cf4..db18518 100644 --- a/src/ui/panel/panel.red +++ b/src/ui/panel/panel.red @@ -35,11 +35,7 @@ fp-border-color?: func [item-type] [ either find [control bool-control str-control arr-control cluster-control] item-type [fp-control-color - 20.20.20] [fp-indicator-color - 20.20.20] ] -fp-cluster-fields: func [item /local cfg flds] [ - cfg: any [item/config copy []] - flds: select cfg 'fields - either flds [flds] [copy []] -] +; fp-cluster-fields → model.red (4A) fp-cluster-height: func [item /local n] [ n: (length? fp-cluster-fields item) / 2 @@ -67,141 +63,9 @@ fp-type-label?: func [item-type] [ ; ══════════════════════════════════════════════════════════ ; FP-ITEM — Constructor following DT-022/023 pattern ; ══════════════════════════════════════════════════════════ -fp-default-label: func [item-type] [ - case [ - item-type = 'bool-control ["Boolean"] - item-type = 'bool-indicator ["Boolean"] - item-type = 'str-control ["String"] - item-type = 'str-indicator ["String"] - item-type = 'arr-control ["Array"] - item-type = 'arr-indicator ["Array"] - item-type = 'cluster-control ["Cluster"] - item-type = 'cluster-indicator ["Cluster"] - item-type = 'waveform-chart ["Chart"] - item-type = 'waveform-graph ["Graph"] - true ["Numeric"] - ] -] +; fp-default-label → model.red (4A) -make-fp-item: func [ - "Crea un item del Front Panel (control o indicator)" - spec [block!] - /local item lbl-spec raw-type -][ - raw-type: any [select spec 'type 'control] - item: make object! [ - id: any [select spec 'id 0] - type: either find [bool-control bool-indicator] raw-type ['control] [raw-type] - data-type: case [ - find [bool-control bool-indicator] raw-type ['boolean] - find [str-control str-indicator] raw-type ['string] - find [arr-control arr-indicator] raw-type ['array] - find [cluster-control cluster-indicator] raw-type ['cluster] - find [waveform-chart waveform-graph] raw-type ['waveform] - true ['numeric] - ] - name: any [select spec 'name ""] - label: none - config: copy any [select spec 'config copy []] - default: case [ - find [bool-control bool-indicator] raw-type [ - any [select spec 'default false] - ] - find [str-control str-indicator] raw-type [ - ; copy siempre: las literales "" en Red son constantes compartidas - copy any [select spec 'default ""] - ] - find [arr-control arr-indicator] raw-type [ - ; copy siempre: los bloques [] son constantes compartidas en Red - copy any [select spec 'default copy []] - ] - find [cluster-control cluster-indicator] raw-type [ - ; block de pares word/valor: [name "" voltage 0.0 active false] - copy any [select spec 'default copy []] - ] - find [waveform-chart waveform-graph] raw-type [ - ; waveform: buffer de valores (array vacío inicialmente) - copy any [select spec 'default copy []] - ] - true [ - any [select spec 'default 0.0] - ] - ] - value: none - offset: any [select spec 'offset 0x0] - ] - item/type: raw-type - ; copy para strings y arrays: garantiza que control e indicador son objetos independientes - item/value: case [ - find [str-control str-indicator] raw-type [ - copy any [select spec 'value item/default] - ] - find [arr-control arr-indicator] raw-type [ - copy any [select spec 'value item/default] - ] - find [cluster-control cluster-indicator] raw-type [ - copy any [select spec 'value copy item/default] - ] - find [waveform-chart waveform-graph] raw-type [ - ; waveform: buffer de valores (array) - copy any [select spec 'value item/default] - ; Asegurar que value es un array - if none? item/value [item/value: copy []] - item/value - ] - true [ - any [select spec 'value item/default] - ] - ] - ; Asegurar que value nunca es none - if none? item/value [ - item/value: either find [waveform-chart waveform-graph] raw-type [copy []] [0.0] - ] - - ; Name: usar explícito, o generar automáticamente - item/name: any [select spec 'name rejoin [form item/type "_" item/id]] - - ; Offset: usar explícito o default - item/offset: any [select spec 'offset 0x0] - - ; Label: acepta bloque [text: "..." ...] o string - ; label/offset = DELTA desde la posición por defecto. - ; Por defecto 0x0: label aparece fp-label-above px encima del body. - ; La posición real se calcula en render: (item/offset/x + delta/x, item/offset/y - fp-label-above + delta/y) - lbl-spec: select spec 'label - item/label: case [ - block? lbl-spec [ - lbl-spec: copy lbl-spec - if none? select lbl-spec 'text [ - append lbl-spec compose [text: (fp-default-label item/type)] - ] - if none? select lbl-spec 'visible [ - append lbl-spec compose [visible: true] - ] - make object! [ - text: any [select lbl-spec 'text ""] - visible: any [select lbl-spec 'visible true] - offset: any [select lbl-spec 'offset 0x0] - ] - ] - string? lbl-spec [ - make object! [ - text: lbl-spec - visible: true - offset: 0x0 - ] - ] - true [ - make object! [ - text: fp-default-label item/type - visible: true - offset: 0x0 - ] - ] - ] - - item -] +; make-fp-item → model.red (4A) fp-value-text: func [item] [ either block? item/value [ @@ -987,156 +851,8 @@ render-panel: func [model panel-width panel-height /local panel-face] [ ; save/load-panel-to-diagram movidas a file-io.red (4A) -; ══════════════════════════════════════════════════════════ -; PERSISTENCE — save front-panel to qvi-diagram format (Phase 4) -; ══════════════════════════════════════════════════════════ -; save/load-panel-to-diagram movidas a file-io.red (4A) -save-panel-to-diagram: func [front-panel-items /local items item kw spec] [ - ; Todos los items van en UN único bloque: [front-panel: [control [...] indicator [...]]] - ; Si se generan bloques separados, select solo devuelve el primero al cargar. - items: copy [] - foreach item front-panel-items [ - kw: case [ - item/type = 'control ['control] - item/type = 'bool-control ['bool-control] - item/type = 'bool-indicator ['bool-indicator] - item/type = 'str-control ['str-control] - item/type = 'str-indicator ['str-indicator] - item/type = 'arr-control ['arr-control] - item/type = 'arr-indicator ['arr-indicator] - item/type = 'cluster-control ['cluster-control] - item/type = 'cluster-indicator ['cluster-indicator] - item/type = 'waveform-chart ['waveform-chart] - item/type = 'waveform-graph ['waveform-graph] - true ['indicator] - ] - ; Construir spec con append/only para el default: - ; compose/deep aplana block! values (splice) — no es válido para arr-control - spec: copy [] - repend spec [to-set-word 'id item/id to-set-word 'type item/type to-set-word 'name item/name] - append spec to-set-word 'label - append/only spec compose/deep [text: (item/label/text) visible: (item/label/visible) offset: (item/label/offset)] - append spec to-set-word 'default - either block? item/value [append/only spec copy item/value] [append spec item/value] - if item/data-type = 'cluster [ - append spec to-set-word 'config - append/only spec copy any [item/config copy []] - ] - repend spec [to-set-word 'offset item/offset] - append items kw - append/only items spec - ] - reduce [to-set-word 'front-panel items] -] - -; ══════════════════════════════════════════════════════════ -; COMPILE PANEL — generate VID layout for .qvi executable (Phase 5) -; ══════════════════════════════════════════════════════════ -gen-panel-var-name: func [item /local s fc] [ - s: copy item/name - if not empty? s [ - fc: uppercase copy/part s 1 - s: rejoin [fc skip s 1] - ] - to-word rejoin ["f" s] -] - -gen-indicator-var-name: func [item /local s fc] [ - s: copy item/name - if not empty? s [ - fc: uppercase copy/part s 1 - s: rejoin [fc skip s 1] - ] - to-word rejoin ["l" s] -] - -compile-panel: func [model /local cmds item ctrl-field-name ind-var-name fn ft fval fld-name] [ - cmds: copy [] - - foreach item model/front-panel [ - case [ - find [control str-control] item/type [ - ctrl-field-name: gen-panel-var-name item - append cmds compose [ - label (item/label/text) - (to-set-word ctrl-field-name) field 120 (form item/default) - return - ] - ] - item/type = 'bool-control [ - ctrl-field-name: gen-panel-var-name item - append cmds compose [ - label (item/label/text) - (to-set-word ctrl-field-name) check (item/label/text) (item/default) - return - ] - ] - item/type = 'arr-control [ - ; Array control: valor fijo en el .qvi (no hay field editable — DT-028) - ind-var-name: gen-indicator-var-name item - append cmds compose [ - label (item/label/text) - (to-set-word ind-var-name) text 120 (rejoin ["[" form item/default "]"]) - return - ] - ] - item/type = 'cluster-control [ - ; Cluster control: un widget por cada campo - foreach [fn ft] fp-cluster-fields item [ - fld-name: to-word rejoin [form item/name "_" form fn] - fval: select any [item/default copy []] fn - append cmds compose [label (rejoin [item/label/text " — " form fn])] - case [ - ft = 'boolean [ - append cmds compose [ - (to-set-word fld-name) check (form fn) (any [fval false]) - return - ] - ] - true [ - append cmds compose [ - (to-set-word fld-name) field 120 (form any [fval ""]) - return - ] - ] - ] - ] - ] - item/type = 'cluster-indicator [ - ; Cluster indicator: un text por cada campo - foreach [fn ft] fp-cluster-fields item [ - fld-name: to-word rejoin [form item/name "_" form fn] - fval: select any [item/default copy []] fn - append cmds compose [ - label (rejoin [item/label/text " — " form fn]) - (to-set-word fld-name) text 120 (form any [fval ""]) - return - ] - ] - ] - find [waveform-chart waveform-graph] item/type [ - ; Waveform: base face con Draw - ind-var-name: gen-indicator-var-name item - append cmds compose [ - label (item/label/text) - (to-set-word ind-var-name) base (as-pair fp-chart-width fp-chart-height) draw [] - return - ] - ] - true [ ; indicator, bool-indicator, str-indicator, arr-indicator - ind-var-name: gen-indicator-var-name item - append cmds compose [ - label (item/label/text) - (to-set-word ind-var-name) text 120 (form item/default) - return - ] - ] - ] - ] - - append cmds compose [button "Run" []] - cmds -] +; save-panel-to-diagram → file-io.red (4A) +; gen-panel-var-name, gen-indicator-var-name, compile-panel → compiler.red (4A) ; ══════════════════════════════════════════════════════════ ; DEMO — standalone test @@ -1177,16 +893,7 @@ add-demo-items: func [model /local ctrl1 ctrl2 ind1] [ model ] -gen-standalone-code: func [model /local vid-code] [ - vid-code: compile-panel model - rejoin [ - "Red [title: {QTorres Panel Demo} Needs: 'View]" newline - "qvi-diagram: []" newline - "view layout [" newline - " " mold vid-code newline - "]" - ] -] +; gen-standalone-code → compiler.red (4A) if find form system/options/script "panel.red" [ ; Use same pattern as canvas.red for demo execution diff --git a/tests/test-blocks.red b/tests/test-blocks.red index 9ddfa88..7f401d3 100644 --- a/tests/test-blocks.red +++ b/tests/test-blocks.red @@ -1,6 +1,6 @@ Red [Title: "QTorres — Tests blocks"] -do %../src/graph/blocks.red +do %../src/graph/model.red ; model.red incluye blocks.red y ahora también make-fp-item (4A) suite "blocks — registro" @@ -172,8 +172,8 @@ assert "waveform-graph no tiene emit (se maneja en compile-panel)" (none? b-grap suite "blocks — waveform: FP item" -; Cargar panel.red para make-fp-item -do %../src/ui/panel/panel.red +; make-fp-item movida a model.red (4A) — ya cargado al inicio del test +; (antes: do %../src/ui/panel/panel.red) wc: make-fp-item [id: 100 type: 'waveform-chart name: "chart_1" label: [text: "Señal" visible: true] offset: 50x50] wg: make-fp-item [id: 101 type: 'waveform-graph name: "graph_1" label: [text: "Array" visible: true] offset: 50x250] From 34aa2cdafc3b44e5ad9490e425832c2ca4b43ca7 Mon Sep 17 00:00:00 2001 From: OpenCodeMCP-BetaTest Date: Wed, 8 Apr 2026 13:16:27 +0200 Subject: [PATCH 04/14] =?UTF-8?q?refactor(4D):=20split=20conservador=20can?= =?UTF-8?q?vas.red=20=E2=80=94=20render,=20di=C3=A1logos,=20n=C3=BAcleo?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit canvas.red (2524 líneas) dividido en 3 ficheros: - canvas-render.red (932): constantes visuales, geometría, render Draw puro - canvas-dialogs.red (397): diálogos de edición, paleta de bloques, SR helpers - canvas.red (1226): hit-test, CRUD, actor render-diagram, demo standalone Order de includes: canvas.red → canvas-render.red → canvas-dialogs.red → panel.red Tests: 465/465 PASS Co-Authored-By: Claude Sonnet 4.6 --- src/ui/diagram/canvas-dialogs.red | 397 +++++++++ src/ui/diagram/canvas-render.red | 932 +++++++++++++++++++++ src/ui/diagram/canvas.red | 1302 +---------------------------- 3 files changed, 1331 insertions(+), 1300 deletions(-) create mode 100644 src/ui/diagram/canvas-dialogs.red create mode 100644 src/ui/diagram/canvas-render.red diff --git a/src/ui/diagram/canvas-dialogs.red b/src/ui/diagram/canvas-dialogs.red new file mode 100644 index 0000000..a0de3d2 --- /dev/null +++ b/src/ui/diagram/canvas-dialogs.red @@ -0,0 +1,397 @@ +Red [ + Title: "QTorres — canvas-dialogs" + Purpose: "Diálogos de edición de nodos, paleta de bloques y SR helpers." + Needs: 'View +] + +; ── canvas-dialogs.red ──────────────────────────────────────────── +; Diálogos de edición de nodos, paleta de bloques y helpers de +; shift registers. Incluido desde canvas.red, tras canvas-render.red +; y las funciones de hit-test. +; Requiere en scope: render-bd, set-config, make-node, gen-node-id, +; make-structure, make-frame, make-shift-register, cluster-fields. +; ────────────────────────────────────────────────────────────────── + +toggle-bool-const: func [node /local cur] [ + cur: any [select node/config 'default false] + set-config node 'default not cur +] + +; Abre diálogo para editar el valor de una constante numérica. +; Patrón view/no-wait con vars de módulo (igual que rename-dialog). +open-const-edit-dialog: func [node canvas-face /local cur-val] [ + cur-val: any [select node/config 'default 0.0] + const-dialog-node: node + const-dialog-canvas: canvas-face + const-dialog-field: none + view/no-wait compose [ + title "Editar constante" + text "Valor:" return + const-dialog-field: field 150 (form cur-val) + on-enter [ + apply-const-value const-dialog-node const-dialog-field/text + const-dialog-canvas/draw: render-bd const-dialog-canvas/extra + unview + ] + return + button "OK" [ + apply-const-value const-dialog-node const-dialog-field/text + const-dialog-canvas/draw: render-bd const-dialog-canvas/extra + unview + ] + button "Cancelar" [unview] + ] +] + +; Actualiza node/config 'default con el nuevo valor numérico. +apply-const-value: func [node new-text /local val] [ + val: attempt [to-float new-text] + if none? val [exit] + set-config node 'default val +] + +; Aplica valor string a un nodo y refresca el canvas. +; Función auxiliar para evitar set-path con valor literal en compose/deep. +str-apply-and-refresh: func [nd txt cnv] [ + apply-str-value nd txt + cnv/draw: render-bd cnv/extra +] + +; Abre diálogo para editar el valor de una constante o control string. +; Usa compose/deep para incrustar node y canvas-face directamente en los handlers, +; evitando el bug de variables de módulo compartidas cuando dos diálogos están abiertos. +open-str-edit-dialog: func [node canvas-face /local cur-val] [ + cur-val: copy any [select node/config 'default ""] + view/no-wait compose/deep [ + title "Editar string" + text "Valor:" return + field 200 (cur-val) + on-enter [ + ; face = el field (on-enter se dispara en el field) + str-apply-and-refresh (node) copy face/text (canvas-face) + unview + ] + return + button "OK" [ + ; Buscar el field en los panes del panel padre + foreach pf face/parent/pane [ + if pf/type = 'field [ + str-apply-and-refresh (node) copy pf/text (canvas-face) + break + ] + ] + unview + ] + button "Cancelar" [unview] + ] +] + +; Actualiza node/config 'default con el nuevo valor string. +apply-str-value: func [node new-text] [ + set-config node 'default new-text +] + +; Actualiza node/config 'default con un block! de valores numéricos parseados desde texto. +; El usuario introduce valores separados por espacios, ej: "1.0 2.0 3.0" +apply-arr-value: func [node new-text /local vals tok parsed-block] [ + parsed-block: copy [] + vals: split trim new-text " " + foreach tok vals [ + tok: trim tok + if not empty? tok [ + append parsed-block any [attempt [to-float tok] attempt [to-integer tok] 0.0] + ] + ] + set-config node 'default parsed-block +] + +arr-apply-and-refresh: func [nd txt cnv] [ + apply-arr-value nd txt + cnv/draw: render-bd cnv/extra +] + +; Abre diálogo para editar el valor de un array constante. +; El usuario introduce números separados por espacios: "1.0 2.0 3.0" +open-arr-edit-dialog: func [node canvas-face /local cur-val cur-text] [ + cur-val: any [select node/config 'default copy []] + cur-text: form cur-val ; "1.0 2.0 3.0" + view/no-wait compose/deep [ + title "Editar array" + text "Valores (separados por espacios):" return + field 250 (cur-text) + on-enter [ + arr-apply-and-refresh (node) copy face/text (canvas-face) + unview + ] + return + button "OK" [ + foreach pf face/parent/pane [ + if pf/type = 'field [ + arr-apply-and-refresh (node) copy pf/text (canvas-face) + break + ] + ] + unview + ] + button "Cancelar" [unview] + ] +] + +apply-rename-label: func [node new-text] [ + either empty? new-text [ + if all [node/label object? node/label] [ + node/label/visible: false + ] + ][ + either all [node/label object? node/label] [ + node/label/text: new-text + node/label/visible: true + ][ + node/label: new-text + ] + ] +] + +; ── Cluster edit dialog ────────────────────────────────────────────────── + +; Guarda la lista de campos en node/config/fields. +apply-cluster-fields: func [node fields-block] [ + set-config node 'fields fields-block +] + +; Parsea el texto del área de edición ("nombre:tipo" por línea) a [nombre 'tipo ...]. +parse-cluster-fields-text: func [text /local result lines parts fname ftype] [ + result: copy [] + foreach line split text "^/" [ + line: trim line + if not empty? line [ + parts: split line ":" + if (length? parts) >= 2 [ + fname: to-word trim parts/1 + ftype: to-word trim parts/2 + unless find [number boolean string] ftype [ftype: 'number] + append result fname + append result to lit-word! ftype + ] + ] + ] + result +] + +; Aplica campos parseados y refresca el canvas. +cluster-apply-and-refresh: func [nd txt cnv] [ + apply-cluster-fields nd parse-cluster-fields-text txt + cnv/draw: render-bd cnv/extra + show cnv +] + +; Vars de módulo para el diálogo de edición de cluster (mismo patrón que rename) +cluster-dialog-node: none +cluster-dialog-canvas: none +cluster-dialog-area: none + +; Abre diálogo para editar los campos de un bundle/unbundle. +; El usuario introduce campos en formato "nombre:tipo", uno por línea. +open-cluster-edit-dialog: func [node canvas-face /local cur-fields cur-text] [ + cluster-dialog-node: node + cluster-dialog-canvas: canvas-face + cluster-dialog-area: none + cur-fields: cluster-fields node + cur-text: copy "" + foreach [fn ft] cur-fields [ + append cur-text rejoin [form fn ":" form to-word ft "^/"] + ] + view/no-wait compose/deep [ + title "Editar campos del cluster" + text {Formato: nombre:tipo (uno por línea)} return + text {Tipos: number boolean string} return + cluster-dialog-area: area 260x180 (cur-text) + return + button "OK" [ + cluster-apply-and-refresh (node) copy cluster-dialog-area/text (canvas-face) + unview + ] + button "Cancelar" [unview] + ] +] + +; Estado del diálogo de renombrado (view/no-wait requiere vars de módulo +; porque la función retorna antes de que el usuario cierre el diálogo). +rename-dialog-node: none +rename-dialog-canvas: none +rename-dialog-field: none + +; Estado del diálogo de edición de constante numérica (mismo patrón) +const-dialog-node: none +const-dialog-canvas: none +const-dialog-field: none + +; ── Paleta de bloques ──────────────────────────────────────────── +; vars de módulo para el diálogo de paleta (mismo patrón que rename) +palette-canvas: none +palette-pos-x: 0 +palette-pos-y: 0 +palette-struct: none ; none = añadir a model/nodes, structure = añadir a st/nodes + +; Añade un nodo al destino correcto: estructura interna o diagrama principal. +palette-add-node: func [node-type /local n nid model] [ + model: palette-canvas/extra + nid: gen-node-id model + n: make-node compose [id: (nid) type: (node-type) x: (palette-pos-x) y: (palette-pos-y)] + either palette-struct [ + ; Case structure: añadir al frame activo + if all [palette-struct/type = 'case-structure block? palette-struct/frames] [ + if palette-struct/active-frame < length? palette-struct/frames [ + append palette-struct/frames/(palette-struct/active-frame + 1)/nodes n + ] + ] + ; While/For loop: añadir a st/nodes + if find [while-loop for-loop] palette-struct/type [ + append palette-struct/nodes n + ] + ][ + append model/nodes n + ] + palette-canvas/draw: render-bd model + show palette-canvas + unview +] + +; Crea una nueva estructura while-loop y la añade al diagrama. +palette-add-structure: func [type [word!] /local nid st model] [ + model: palette-canvas/extra + nid: gen-node-id model + st: make-structure compose [id: (nid) type: (type) x: (palette-pos-x) y: (palette-pos-y)] + if type = 'case-structure [append st/frames make-frame [id: 0 label: "0"]] + append model/structures st + palette-canvas/draw: render-bd model + show palette-canvas + unview +] + +open-palette: func [face x y /struct target-struct] [ + palette-canvas: face + palette-pos-x: x + palette-pos-y: y + palette-struct: target-struct + view/no-wait [ + title "Añadir bloque" + text "Aritmética:" return + button 80 "Add +" [palette-add-node 'add] + button 80 "Sub -" [palette-add-node 'sub] + button 80 "Mul *" [palette-add-node 'mul] + button 80 "Div /" [palette-add-node 'div] return + text "Constante / salida:" return + button 80 "Const" [palette-add-node 'const] + button 80 "Display" [palette-add-node 'display] return + text "Lógica:" return + button 80 "AND" [palette-add-node 'and-op] + button 80 "OR" [palette-add-node 'or-op] + button 80 "NOT" [palette-add-node 'not-op] + button 80 "B-Const" [palette-add-node 'bool-const] return + text "Comparadores:" return + button 80 ">" [palette-add-node 'gt-op] + button 80 "<" [palette-add-node 'lt-op] + button 80 "=" [palette-add-node 'eq-op] + button 80 "!=" [palette-add-node 'neq-op] return + text "String:" return + button 80 "S-Const" [palette-add-node 'str-const] + button 80 "Concat" [palette-add-node 'concat] + button 80 "Len" [palette-add-node 'str-length] + button 80 "→STR" [palette-add-node 'to-string] return + text "Array:" return + button 80 "Arr[]" [palette-add-node 'arr-const] + button 80 "Build[]" [palette-add-node 'build-array] + button 80 "Index[]" [palette-add-node 'index-array] return + button 80 "Size[]" [palette-add-node 'array-size] + button 80 "Subset[]" [palette-add-node 'array-subset] return + text "Cluster:" return + button 80 "Bundle" [palette-add-node 'bundle] + button 80 "Unbundle" [palette-add-node 'unbundle] return + text "Estructuras:" return + button 80 "While" [palette-add-structure 'while-loop] + button 80 "For" [palette-add-structure 'for-loop] + button 80 "Case" [palette-add-structure 'case-structure] return + button 80 "Add SR" [ + if palette-struct [ + unview + open-add-sr-dialog palette-canvas palette-struct + ] + ] + return + button "Cancelar" [unview] + ] +] + +; ── Shift Register helpers ────────────────────────────────────────── + +; Añade un SR de tipo dado a la estructura, calculando el y-offset automáticamente. +add-sr-to-structure: func [st dtype /local y sr] [ + y: 40 + (50 * length? st/shift-regs) + sr: make-shift-register compose [data-type: (dtype) y-offset: (y)] + append st/shift-regs sr +] + +; Vars de módulo para diálogos SR (patrón view/no-wait) +add-sr-canvas: none +add-sr-struct: none +sr-edit-canvas: none +sr-edit-sr-obj: none + +; Abre diálogo para elegir el tipo del nuevo shift register. +open-add-sr-dialog: func [canvas st] [ + add-sr-canvas: canvas + add-sr-struct: st + view/no-wait [ + title "Añadir shift register" + text "Tipo de dato:" return + button 80 "Number" [add-sr-to-structure add-sr-struct 'number + add-sr-canvas/draw: render-bd add-sr-canvas/extra + show add-sr-canvas unview] + button 80 "Boolean" [add-sr-to-structure add-sr-struct 'boolean + add-sr-canvas/draw: render-bd add-sr-canvas/extra + show add-sr-canvas unview] + button 80 "String" [add-sr-to-structure add-sr-struct 'string + add-sr-canvas/draw: render-bd add-sr-canvas/extra + show add-sr-canvas unview] return + button "Cancelar" [unview] + ] +] + +; Actualiza el init-value de un SR desde texto. +apply-sr-init-value: func [sr new-text /local val] [ + val: switch sr/data-type [ + string [new-text] + boolean [any [attempt [to-logic new-text] false]] + ] + if none? val [val: any [attempt [to-float new-text] 0.0]] + sr/init-value: val +] + +; Abre diálogo para editar el valor inicial de un SR. +open-sr-edit-dialog: func [canvas sr /local cur] [ + sr-edit-canvas: canvas + sr-edit-sr-obj: sr + cur: form sr/init-value + view/no-wait compose [ + title "Valor inicial SR" + text (rejoin [sr/name " [" form sr/data-type "]"]) return + text "Valor inicial:" return + sr-edit-fld: field 150 (cur) + on-enter [ + apply-sr-init-value sr-edit-sr-obj sr-edit-fld/text + sr-edit-canvas/draw: render-bd sr-edit-canvas/extra + unview + ] + return + button "OK" [ + apply-sr-init-value sr-edit-sr-obj sr-edit-fld/text + sr-edit-canvas/draw: render-bd sr-edit-canvas/extra + unview + ] + button "Cancelar" [unview] + ] +] + +; Borra el elemento seleccionado (nodo, wire o estructura completa). +; Llamar desde el on-key del window padre con: canvas-delete-selected canvas diff --git a/src/ui/diagram/canvas-render.red b/src/ui/diagram/canvas-render.red new file mode 100644 index 0000000..79de623 --- /dev/null +++ b/src/ui/diagram/canvas-render.red @@ -0,0 +1,932 @@ +Red [ + Title: "QTorres — canvas-render" + Purpose: "Render puro del Block Diagram: constantes visuales, geometría y Draw." + Needs: 'View +] + +; ── canvas-render.red ───────────────────────────────────────────── +; Render puro del Block Diagram: constantes visuales, geometría de +; nodos y funciones Draw. Incluido desde canvas.red. +; No contiene estado mutable ni side-effects de UI. +; ────────────────────────────────────────────────────────────────── + +block-width: 120 block-height: 50 port-radius: 8 grid-size: 20 + +col-canvas: 225.228.235 +col-grid: 200.203.212 +col-block-ctrl: 50.100.180 +col-block-ind: 175.125.20 +col-block-op: 55.75.105 +col-wire: 195.95.20 +col-wire-bool: 20.160.20 +col-wire-str: 220.100.160 +col-wire-cluster: 139.69.19 +col-wire-sel: 0.160.200 +col-port-in: 50.110.200 +col-port-out: 195.80.25 +col-sel: 0.175.210 +col-text: 240.245.250 +col-black: 0.0.0 + +; Colores de estructuras contenedoras (while-loop) +col-struct-border: 55.80.120 ; borde azulado oscuro +col-struct-bg: 205.210.220 ; fondo ligeramente más oscuro que canvas +col-struct-term-i: 50.100.180 ; terminal iteración (azul como control) +col-struct-term-cond: 20.160.20 ; terminal condición (verde como wire bool) +struct-terminal-size: 14 ; tamaño del cuadrado terminal i y handle resize +sr-terminal-half: 6 ; semitamaño del triángulo SR (triángulo 12px total) + +; Case Structure — dimensiones +case-nav-height: 24 ; altura de la barra de navegación +case-btn-size: 18 ; tamaño de botones ◀ ▶ [+][-] +col-case-nav-bg: 160.185.215 ; fondo de barra de navegación + +; Compensación vertical de texto (8px en Linux por diferencia de baseline) +text-dy: either system/platform = 'Linux [8] [0] + +; ══════════════════════════════════════════════════════════ +; GEOMETRÍA DE NODOS — funciones puras sin side-effects +; ══════════════════════════════════════════════════════════ +; Devuelve el color de un tipo de nodo leyendo la categoría del block-registry. +block-color: func [node-type /local cat] [ + cat: block-category to-word node-type + case [ + cat = 'input [col-block-ctrl] + cat = 'output [col-block-ind] + cat = 'cluster [col-wire-cluster] + true [col-block-op] + ] +] + +; Devuelve los puertos de entrada de un nodo. +; Para bundle: puertos dinámicos desde config/fields. +; Para el resto: consulta el block-registry. +in-ports: func [node] [ + case [ + node/type = 'bundle [cluster-in-ports node] + node/type = 'cluster-indicator [cluster-in-ports node] + true [any [block-in-ports to-word node/type []]] + ] +] + +; Devuelve los puertos de salida de un nodo. +; Para unbundle: puertos dinámicos desde config/fields. +; Para el resto: consulta el block-registry. +out-ports: func [node] [ + case [ + node/type = 'unbundle [cluster-out-ports node] + node/type = 'cluster-control [cluster-out-ports node] + true [any [block-out-ports to-word node/type []]] + ] +] + +; Devuelve el tipo de dato de un puerto de salida ('number por defecto). +; Para unbundle: los puertos de salida son campos dinámicos del cluster. +port-out-type: func [node port-name /local bdef p] [ + if node/type = 'unbundle [return cluster-field-type node to-word port-name] + bdef: find-block to-word node/type + if none? bdef [return 'number] + foreach p bdef/outputs [ + if p/name = to-word port-name [return p/type] + ] + 'number +] + +; Devuelve el tipo de dato de un puerto de entrada ('number por defecto). +; Para bundle: los puertos de entrada son campos dinámicos del cluster. +port-in-type: func [node port-name /local bdef p] [ + if node/type = 'bundle [return cluster-field-type node to-word port-name] + bdef: find-block to-word node/type + if none? bdef [return 'number] + foreach p bdef/inputs [ + if p/name = to-word port-name [return p/type] + ] + 'number +] + +; Devuelve el color de wire para un tipo de dato. +wire-data-color: func [data-type] [ + case [ + data-type = 'boolean [col-wire-bool] + data-type = 'string [col-wire-str] + data-type = 'cluster [col-wire-cluster] + data-type = 'array [col-wire] ; mismo naranja que number, diferenciado por línea doble + true [col-wire] + ] +] + +; Devuelve la posición del terminal SR (▲ borde izquierdo o ▼ borde derecho). +sr-xy: func [st sr side] [ + either side = 'left [ + as-pair st/x (to-integer st/y + sr/y-offset) + ][ + as-pair (to-integer st/x + st/w) (to-integer st/y + sr/y-offset) + ] +] + +; Devuelve el color del terminal SR según su data-type. +sr-type-color: func [data-type] [ + case [ + data-type = 'boolean [col-wire-bool] + data-type = 'string [col-wire-str] + data-type = 'array [col-wire] + true [col-wire] + ] +] + +; Busca un SR por nombre en un bloque de shift-regs. +; Usa while/pick para evitar problemas de posición de serie con foreach. +find-sr: func [shift-regs [block!] port-name [word!] /local k sr] [ + k: 1 + while [k <= length? shift-regs] [ + sr: pick shift-regs k + if (to-word sr/name) = port-name [return sr] + k: k + 1 + ] + none +] + +; Genera comandos Draw para una línea daseada horizontal o vertical. +; Simula el patrón característico del wire string (visual-spec §4.2). +draw-dashed-segment: func [p1 [pair!] p2 [pair!] /local cmds dash gap pos end-v horiz] [ + cmds: copy [] + dash: 5 gap: 3 + horiz: p1/y = p2/y + either horiz [ + pos: p1/x end-v: p2/x + if pos > end-v [pos: p2/x end-v: p1/x] + while [pos < end-v] [ + append cmds compose [ + line (as-pair pos p1/y) (as-pair (min pos + dash end-v) p1/y) + ] + pos: pos + dash + gap + ] + ][ + pos: p1/y end-v: p2/y + if pos > end-v [pos: p2/y end-v: p1/y] + while [pos < end-v] [ + append cmds compose [ + line (as-pair p1/x pos) (as-pair p1/x (min pos + dash end-v)) + ] + pos: pos + dash + gap + ] + ] + cmds +] + +port-xy: func [node port-name direction /local ports port-index found] [ + either direction = 'in [ + ports: in-ports node + found: find ports port-name + port-index: either found [index? found] [1] + as-pair (node/x - port-radius) (node/y + 12 + ((port-index - 1) * 20)) + ][ + ports: out-ports node + found: find ports port-name + port-index: either found [index? found] [1] + as-pair (node/x + block-width + port-radius) (node/y + 12 + ((port-index - 1) * 20)) + ] +] + +; Devuelve la altura visual de un nodo. +; bundle/unbundle/cluster-control/cluster-indicator: variable según número de campos. +; Resto: block-height fijo. +node-height: func [node /local n-in n-out] [ + case [ + find [bundle unbundle cluster-control cluster-indicator] node/type [ + n-in: length? in-ports node + n-out: length? out-ports node + max block-height (12 + (max n-in n-out) * 20 + 10) + ] + true [block-height] + ] +] + +; ══════════════════════════════════════════════════════════ +; MODELO — todo el estado mutable vive aquí +; ══════════════════════════════════════════════════════════ +; make-diagram-model movida a model.red (4A refactor) + +gen-node-id: func [model /local next-id] [ + next-id: model/next-id + model/next-id: model/next-id + 1 + next-id +] + +; ══════════════════════════════════════════════════════════ +; RENDER — funciones puras que reciben modelo y devuelven +; bloques de primitivas Draw +; ══════════════════════════════════════════════════════════ +render-grid: func [canvas-width canvas-height /local cmds x y] [ + cmds: compose [pen (col-grid) fill-pen (col-grid) line-width 1] + x: grid-size + while [x < canvas-width] [ + y: grid-size + while [y < canvas-height] [ + append cmds compose [circle (as-pair x y) 1] + y: y + grid-size + ] + x: x + grid-size + ] + cmds +] + +; ── Helpers de render: reutilizables por render-bd y render-structure ──────── + +render-wire-list: func [ + "Genera Draw cmds para una lista de wires dado su lista de nodos fuente" + wires nodes selected-wire + /local cmds wire src-node dst-node out-xy in-xy mid-x wire-dtype wire-color node +][ + cmds: copy [] + foreach wire wires [ + src-node: find-node-by-id nodes wire/from-node + dst-node: find-node-by-id nodes wire/to-node + if all [src-node dst-node] [ + out-xy: port-xy src-node wire/from-port 'out + in-xy: port-xy dst-node wire/to-port 'in + mid-x: to-integer (out-xy/x + in-xy/x) / 2 + wire-dtype: port-out-type src-node wire/from-port + wire-color: either same? wire selected-wire [col-wire-sel] [wire-data-color wire-dtype] + case [ + all [wire-dtype = 'string not same? wire selected-wire] [ + append cmds compose [pen (wire-color) line-width 2] + append cmds draw-dashed-segment out-xy as-pair mid-x out-xy/y + append cmds draw-dashed-segment as-pair mid-x out-xy/y as-pair mid-x in-xy/y + append cmds draw-dashed-segment as-pair mid-x in-xy/y in-xy + ] + all [wire-dtype = 'array not same? wire selected-wire] [ + ; Línea doble: trazo grueso exterior + trazo fino interior del color del canvas + append cmds compose [ + pen (wire-color) line-width 4 + line (out-xy) (as-pair mid-x out-xy/y) (as-pair mid-x in-xy/y) (in-xy) + pen col-canvas line-width 1 + line (out-xy) (as-pair mid-x out-xy/y) (as-pair mid-x in-xy/y) (in-xy) + ] + ] + true [ + append cmds compose [ + pen (wire-color) line-width 2 + line (out-xy) (as-pair mid-x out-xy/y) (as-pair mid-x in-xy/y) (in-xy) + ] + ] + ] + ] + ] + cmds +] + +render-node-list: func [ + "Genera Draw cmds para una lista de nodos" + nodes selected-node + /local cmds node node-color type-label ports in-port-y out-port-y port +][ + cmds: copy [] + foreach node nodes [ + ; bundle/unbundle/cluster-control/cluster-indicator tienen render propio (altura variable, puertos dinámicos) + if find [bundle unbundle cluster-control cluster-indicator] node/type [ + append cmds render-cluster-node node selected-node + continue + ] + node-color: block-color node/type + append cmds compose [ + pen (node-color - 20.20.20) line-width 1 fill-pen (node-color) + box (as-pair node/x node/y) (as-pair (node/x + block-width) (node/y + block-height)) 5 + ] + append cmds compose [ + pen off fill-pen (node-color + 30.30.30) + box (as-pair node/x node/y) (as-pair (node/x + 4) (node/y + block-height)) 0 + ] + type-label: switch/default node/type [ + control ["DBL"] + indicator ["DBL"] + add ["ADD +"] + sub ["SUB -"] + mul ["MUL *"] + div ["DIV /"] + display ["DISP"] + subvi ["SUBVI"] + const [form any [select node/config 'default 0.0]] + bool-const [either any [select node/config 'default false] ["T"] ["F"]] + bool-control ["TF"] + bool-indicator ["TF"] + and-op ["AND"] + or-op ["OR"] + not-op ["NOT"] + gt-op [">"] + lt-op ["<"] + eq-op ["="] + str-const [any [select node/config 'default ""]] + str-control [to-string any [select node/config 'default "STR"]] + str-indicator ["STR"] + concat ["CONCAT"] + str-length ["LEN"] + to-string ["→STR"] + arr-const [rejoin ["[" form any [select node/config 'default copy []] "]"]] + arr-control ["ARR"] + arr-indicator ["ARR"] + build-array ["BUILD[]"] + index-array ["IDX[]"] + array-size ["SIZE[]"] + array-subset ["SUB[]"] + ] [uppercase form node/type] + either all [node/label object? node/label node/label/visible] [ + append cmds compose [ + fill-pen col-text + text (as-pair (node/x + 10) (node/y + 10 + text-dy)) (any [node/label/text ""]) + text (as-pair (node/x + 10) (node/y + 26 + text-dy)) (type-label) + ] + ][ + either all [node/label string? node/label] [ + append cmds compose [ + fill-pen col-text + text (as-pair (node/x + 10) (node/y + 10 + text-dy)) (node/label) + text (as-pair (node/x + 10) (node/y + 26 + text-dy)) (type-label) + ] + ][ + append cmds compose [ + fill-pen col-text + text (as-pair (node/x + 10) (node/y + 14 + text-dy)) (type-label) + ] + ] + ] + ports: in-ports node + in-port-y: node/y + 12 + foreach port ports [ + append cmds compose [ + pen col-port-in fill-pen col-port-in + circle (as-pair (node/x - port-radius) in-port-y) (port-radius) + fill-pen col-text + text (as-pair (node/x - port-radius - 22) (in-port-y - 7 + text-dy)) (form port) + ] + in-port-y: in-port-y + 20 + ] + ports: out-ports node + out-port-y: node/y + 12 + foreach port ports [ + append cmds compose [ + pen col-port-out fill-pen col-port-out + circle (as-pair (node/x + block-width + port-radius) out-port-y) (port-radius) + fill-pen col-text + text (as-pair (node/x + block-width + port-radius + 12) (out-port-y - 7 + text-dy)) (form port) + ] + out-port-y: out-port-y + 20 + ] + if same? node selected-node [ + append cmds compose [ + pen col-sel line-width 2 fill-pen off + box (as-pair (node/x - 3) (node/y - 3)) (as-pair (node/x + block-width + 3) (node/y + block-height + 3)) 6 + line-width 1 + ] + ] + ] + cmds +] + +; ══════════════════════════════════════════════════════════ +; RENDER-CLUSTER-NODE — Bundle / Unbundle con puertos dinámicos +; ══════════════════════════════════════════════════════════ + +render-cluster-node: func [ + "Genera Draw cmds para un nodo bundle/unbundle con altura variable y puertos coloreados" + node selected-node + /local cmds node-color h type-label ports in-port-y out-port-y port port-col +][ + cmds: copy [] + node-color: col-wire-cluster + h: node-height node + + ; Cuerpo del nodo (altura variable) + append cmds compose [ + pen (node-color - 20.20.20) line-width 1 fill-pen (node-color) + box (as-pair node/x node/y) (as-pair (node/x + block-width) (node/y + h)) 5 + pen off fill-pen (node-color + 30.30.30) + box (as-pair node/x node/y) (as-pair (node/x + 4) (node/y + h)) 0 + ] + + ; Etiqueta de tipo centrada verticalmente + type-label: case [ + node/type = 'bundle ["BUNDLE"] + node/type = 'unbundle ["UNBUNDLE"] + node/type = 'cluster-control ["CLU-CTRL"] + true ["CLU-IND"] + ] + append cmds compose [ + fill-pen col-text + text (as-pair (node/x + 8) (node/y + 14 + text-dy)) (type-label) + ] + + ; Puertos de entrada (coloreados por tipo de campo) + ports: in-ports node + in-port-y: node/y + 12 + foreach port ports [ + port-col: wire-data-color port-in-type node port + append cmds compose [ + pen (port-col) fill-pen (port-col) + circle (as-pair (node/x - port-radius) in-port-y) (port-radius) + fill-pen col-text + text (as-pair (node/x - port-radius - 22) (in-port-y - 7)) (form port) + ] + in-port-y: in-port-y + 20 + ] + + ; Puertos de salida (coloreados por tipo de campo o cluster) + ports: out-ports node + out-port-y: node/y + 12 + foreach port ports [ + port-col: wire-data-color port-out-type node port + append cmds compose [ + pen (port-col) fill-pen (port-col) + circle (as-pair (node/x + block-width + port-radius) out-port-y) (port-radius) + fill-pen col-text + text (as-pair (node/x + block-width + port-radius + 12) (out-port-y - 7)) (form port) + ] + out-port-y: out-port-y + 20 + ] + + ; Borde de selección + if same? node selected-node [ + append cmds compose [ + pen col-sel line-width 2 fill-pen off + box (as-pair (node/x - 3) (node/y - 3)) (as-pair (node/x + block-width + 3) (node/y + h + 3)) 6 + line-width 1 + ] + ] + cmds +] + +; ══════════════════════════════════════════════════════════ +; RENDER-CASE-STRUCTURE — Case Structure con múltiples frames +; ══════════════════════════════════════════════════════════ + +render-case-structure: func [ + "Genera Draw cmds para una Case Structure con barra de navegación" + st model + /local cmds bx by bx2 by2 nav-h act-frame frame-label sel-x +][ + cmds: copy [] + bx: st/x by: st/y bx2: st/x + st/w by2: st/y + st/h + nav-h: case-nav-height + + ; 1) Fondo + borde del contenedor + append cmds compose [ + pen (col-struct-border) line-width 2 fill-pen (col-struct-bg) + box (as-pair bx by) (as-pair bx2 by2) 8 + line-width 1 + ] + + ; 2) Barra de navegación (fondo más oscuro) + append cmds compose [ + pen (col-struct-border) fill-pen (col-case-nav-bg) + box (as-pair (bx + 2) (by + 2)) (as-pair (bx2 - 2) (by + nav-h)) 4 + ] + + ; 3) Label "Case Structure" + if all [st/label object? st/label] [ + append cmds compose [ + pen off fill-pen col-black + text (as-pair (bx + 8) (by + 5 + text-dy)) (st/label/text) + ] + ] + + ; 4) Botones de navegación ◀ ▶ [+][-] + ; ◀ (izquierda) en x: bx+8 + append cmds compose [ + pen (col-struct-border) line-width 1 fill-pen (col-struct-bg + 30.30.30) + box (as-pair (bx + 8) (by + 4)) (as-pair (bx + 26) (by + 22)) 2 + fill-pen (col-black) + text (as-pair (bx + 13) (by + 4 + text-dy)) "<" + ] + ; ▶ (derecha) en x: bx+28 + append cmds compose [ + pen (col-struct-border) line-width 1 fill-pen (col-struct-bg + 30.30.30) + box (as-pair (bx + 28) (by + 4)) (as-pair (bx + 46) (by + 22)) 2 + fill-pen (col-black) + text (as-pair (bx + 33) (by + 4 + text-dy)) ">" + ] + + ; 5) Indicador de frame activo + act-frame: either all [block? st/frames st/active-frame < length? st/frames] [ + st/frames/(st/active-frame + 1) + ][ + none + ] + frame-label: either act-frame [act-frame/label] ["?"] + append cmds compose [ + fill-pen (col-black) + text (as-pair (bx + 52) (by + 5 + text-dy)) (frame-label) + ] + + ; 6) Botones [+][-] en esquina derecha de la barra + ; [+] en x: bx2-48 + append cmds compose [ + pen (col-struct-border) line-width 1 fill-pen (col-struct-bg + 20.20.20) + box (as-pair (bx2 - 48) (by + 4)) (as-pair (bx2 - 30) (by + 22)) 2 + fill-pen (col-black) + text (as-pair (bx2 - 43) (by + 4 + text-dy)) "+" + ] + ; [-] en x: bx2-26 + append cmds compose [ + pen (col-struct-border) line-width 1 fill-pen (col-struct-bg + 20.20.20) + box (as-pair (bx2 - 26) (by + 4)) (as-pair (bx2 - 8) (by + 22)) 2 + fill-pen (col-black) + text (as-pair (bx2 - 20) (by + 4 + text-dy)) "-" + ] + + ; 7) Terminal selector [?] — esquina superior izquierda debajo de la barra + ; (número entero = naranja, booleano = verde) + sel-x: bx + 8 + append cmds compose [ + pen (col-struct-border) line-width 1 fill-pen (col-wire) + box (as-pair sel-x (by + nav-h + 4)) + (as-pair (sel-x + 14) (by + nav-h + 18)) 2 + fill-pen (col-black) + text (as-pair (sel-x + 3) (by + nav-h + 3 + text-dy)) "?" + ] + + ; 8) Handle de resize — esquina inferior-derecha 10x10 + append cmds compose [ + pen col-struct-border line-width 1 fill-pen (col-struct-border + 40.40.40) + box (as-pair (bx2 - 10) (by2 - 10)) (as-pair bx2 by2) 0 + ] + + ; 9) Borde de selección cian + if all [same? st model/selected-struct none? model/selected-node] [ + append cmds compose [ + pen col-sel line-width 2 fill-pen off + box (as-pair (bx - 3) (by - 3)) (as-pair (bx2 + 3) (by2 + 3)) 10 + line-width 1 + ] + ] + + ; 10) Wire del selector (si hay selector-wire) + if st/selector-wire [ + do [ + sel-src: none + sel-src: find-node-by-id model/nodes st/selector-wire/from + if sel-src [ + src-xy: port-xy sel-src st/selector-wire/port 'out + dst-xy: as-pair (sel-x + 7) (by + nav-h + 11) + mid-cx: to-integer (src-xy/x + dst-xy/x) / 2 + ; Color según tipo: detectado del wire conectado + append cmds compose [ + pen (col-wire) line-width 2 + line (src-xy) (as-pair mid-cx src-xy/y) (as-pair mid-cx dst-xy/y) (dst-xy) + line-width 1 + ] + ] + ] + ] + + ; 11) Renderizar nodos y wires del frame activo + if act-frame [ + append cmds render-node-list act-frame/nodes model/selected-node + append cmds render-wire-list act-frame/wires act-frame/nodes model/selected-wire + ] + + cmds +] + +render-structure: func [ + "Genera Draw cmds para una estructura contenedora (while-loop, for-loop, case-structure)" + st model + /local cmds bx by bx2 by2 tx sr sr-col y-off _w _sr-has-ext-wire + _sr-found _src-xy _in-xy _out-xy _dst-xy _mid-x _sr-col2 +][ + ; Bifurcación: Case Structure tiene renderizado propio + if st/type = 'case-structure [ + return render-case-structure st model + ] + + ; ── WHILE/FOR LOOP ───────────────────────────────────── + cmds: copy [] + bx: st/x by: st/y bx2: st/x + st/w by2: st/y + st/h + tx: struct-terminal-size + + ; 1) Fondo + borde del contenedor + append cmds compose [ + pen (col-struct-border) line-width 2 fill-pen (col-struct-bg) + box (as-pair bx by) (as-pair bx2 by2) 8 + line-width 1 + ] + + ; 2) Label arriba-izquierda + if all [st/label object? st/label] [ + append cmds compose [ + pen off fill-pen (col-struct-border) + text (as-pair (bx + 8) (by + 6 + text-dy)) (st/label/text) + ] + ] + + ; 3) Terminal iteración [i] — cuadrado azul abajo-izquierda + append cmds compose [ + pen (col-struct-border) line-width 1 fill-pen (col-struct-term-i) + box (as-pair (bx + 8) (by2 - tx - 8)) + (as-pair (bx + 8 + tx) (by2 - 8)) 2 + pen off fill-pen col-text + text (as-pair (bx + 11) (by2 - tx - 5 + text-dy)) "i" + ] + + ; 4) Terminal condición [●] — círculo verde abajo-derecha (solo while-loop) + ; Desplazado a bx2-24, by2-24 para no solapar con el handle de resize (14x14) + if st/type = 'while-loop [ + append cmds compose [ + pen (col-struct-border) line-width 1 fill-pen (col-struct-term-cond) + circle (as-pair (bx2 - 24) (by2 - 24)) 8 + ] + ] + + ; 4b) Terminal count [N] — cuadrado naranja arriba-izquierda (solo for-loop) + if st/type = 'for-loop [ + append cmds compose [ + pen (col-struct-border) line-width 1 fill-pen (col-wire) + box (as-pair (bx + 8) (by + 8)) + (as-pair (bx + 8 + tx) (by + 8 + tx)) 2 + pen off fill-pen col-text + text (as-pair (bx + 11) (by + 11 + text-dy)) "N" + ] + ] + + ; 5) Terminales shift register — ▲ borde izquierdo, ▼ borde derecho + if block? st/shift-regs [ + foreach sr head st/shift-regs [ + sr-col: sr-type-color sr/data-type + y-off: sr/y-offset + append cmds compose [ + pen (col-struct-border) line-width 1 fill-pen (sr-col) + ; ▲ izquierdo (lectura — valor entra al loop) + triangle (as-pair (bx - sr-terminal-half) (by + y-off + sr-terminal-half)) + (as-pair (bx + sr-terminal-half) (by + y-off + sr-terminal-half)) + (as-pair bx (by + y-off - sr-terminal-half)) + ; ▼ derecho (escritura — valor sale del loop) + triangle (as-pair (bx2 - sr-terminal-half) (by + y-off - sr-terminal-half)) + (as-pair (bx2 + sr-terminal-half) (by + y-off - sr-terminal-half)) + (as-pair bx2 (by + y-off + sr-terminal-half)) + ] + ; Texto init-value junto al ▲ — solo si no hay wire externo conectado a este SR + _sr-has-ext-wire: false + foreach _w model/wires [ + if all [_w/to-node = st/id (to-word _w/to-port) = to-word sr/name] [ + _sr-has-ext-wire: true + ] + ] + unless _sr-has-ext-wire [ + append cmds compose [ + pen off fill-pen (col-struct-border) + text (as-pair (bx + 10) (by + y-off - 7 + text-dy)) (form sr/init-value) + ] + ] + ] + ] + + ; 6) Handle de resize — cuadrado 10x10 esquina inferior-derecha + append cmds compose [ + pen col-struct-border line-width 1 fill-pen (col-struct-border + 40.40.40) + box (as-pair (bx2 - 10) (by2 - 10)) (as-pair bx2 by2) 0 + ] + + ; 7) Borde de selección cian — solo cuando la estructura en sí está seleccionada + ; (no cuando se ha seleccionado un nodo interno) + if all [same? st model/selected-struct none? model/selected-node] [ + append cmds compose [ + pen col-sel line-width 2 fill-pen off + box (as-pair (bx - 3) (by - 3)) (as-pair (bx2 + 3) (by2 + 3)) 10 + line-width 1 + ] + ] + + ; 7b) Highlight del SR seleccionado — círculos cian en ambos triángulos + if all [model/selected-sr same? st model/selected-sr/1] [ + do [ + _sel-sr: model/selected-sr/2 + _sel-y: to-integer by + _sel-sr/y-offset + append cmds compose [ + pen col-sel line-width 2 fill-pen off + circle (as-pair bx _sel-y) (sr-terminal-half + 4) + circle (as-pair bx2 _sel-y) (sr-terminal-half + 4) + line-width 1 + ] + ] + ] + + ; 8) Wires desde terminales virtuales: iter (-3), SR-left (-1), SR-right (-2) + do [ + half-tx: to-integer (tx / 2) ; 14/2 = 7 — precomputado para evitar precedencia + iter-src: as-pair (to-integer bx + 8 + half-tx) (to-integer by2 - half-tx - 8) + foreach w st/wires [ + ; Iter (-3) → nodo interno + if w/from-node = -3 [ + nd: find-node-by-id st/nodes w/to-node + if nd [ + in-xy: port-xy nd w/to-port 'in + mid-x: to-integer (iter-src/x + in-xy/x) / 2 + append cmds compose [ + pen col-wire line-width 2 + line (iter-src) (as-pair mid-x iter-src/y) + (as-pair mid-x in-xy/y) (in-xy) + line-width 1 + ] + ] + ] + ; SR-left (-1) → nodo interno + if w/from-node = -1 [ + _sr-found: find-sr st/shift-regs w/from-port + if _sr-found [ + nd: find-node-by-id st/nodes w/to-node + if nd [ + _src-xy: sr-xy st _sr-found 'left + _in-xy: port-xy nd w/to-port 'in + _mid-x: to-integer (_src-xy/x + _in-xy/x) / 2 + _sr-col2: sr-type-color _sr-found/data-type + append cmds compose [ + pen (_sr-col2) line-width 2 + line (_src-xy) (as-pair _mid-x _src-xy/y) + (as-pair _mid-x _in-xy/y) (_in-xy) + line-width 1 + ] + ] + ] + ] + ; Nodo interno → SR-right (-2) + if w/to-node = -2 [ + _sr-found: find-sr st/shift-regs w/to-port + if _sr-found [ + nd: find-node-by-id st/nodes w/from-node + if nd [ + _out-xy: port-xy nd w/from-port 'out + _dst-xy: sr-xy st _sr-found 'right + _mid-x: to-integer (_out-xy/x + _dst-xy/x) / 2 + _sr-col2: sr-type-color _sr-found/data-type + append cmds compose [ + pen (_sr-col2) line-width 2 + line (_out-xy) (as-pair _mid-x _out-xy/y) + (as-pair _mid-x _dst-xy/y) (_dst-xy) + line-width 1 + ] + ] + ] + ] + ] + ] + + ; 9) Wires internos normales (entre nodos reales) + append cmds render-wire-list st/wires st/nodes model/selected-wire + + ; 10) Nodos internos + append cmds render-node-list st/nodes model/selected-node + + ; 11) Wire de condición — línea desde el nodo fuente hasta el terminal ● + if st/cond-wire [ + do [ + cond-src: none + cond-src: find-node-by-id st/nodes st/cond-wire/from + if cond-src [ + src-xy: port-xy cond-src st/cond-wire/port 'out + dst-xy: as-pair (bx2 - 24) (by2 - 24) + mid-cx: to-integer (src-xy/x + dst-xy/x) / 2 + append cmds compose [ + pen (col-wire-bool) line-width 2 + line (src-xy) (as-pair mid-cx src-xy/y) (as-pair mid-cx dst-xy/y) (dst-xy) + ] + ] + ] + ] + + cmds +] + +render-bd: func [model /local cmds src-port-xy mid st] [ + cmds: copy [] + + ; 0) Grid de fondo + append cmds render-grid 880 490 + + ; 1) Estructuras contenedoras (detrás de los nodos normales) + if block? model/structures [ + foreach st model/structures [ + append cmds render-structure st model + ] + ] + + ; 2) Wires permanentes normales + append cmds render-wire-list model/wires model/nodes model/selected-wire + + ; 2b) Wires externos de shift registers (ext→▲ y ▼→ext) y wire N de for-loop + if block? model/structures [ + foreach _sst model/structures [ + foreach _sw model/wires [ + ; For-loop: External → [N] (to-node = structure ID, to-port = "count") + if all [_sst/type = 'for-loop _sw/to-node = _sst/id _sw/to-port = 'count] [ + do [ + _snd: none + _snd: find-node-by-id model/nodes _sw/from-node + if _snd [ + _sout: port-xy _snd _sw/from-port 'out + _htx: to-integer (struct-terminal-size / 2) + _ndst: as-pair (to-integer _sst/x + 8 + _htx) + (to-integer _sst/y + 8 + _htx) + _smx: to-integer (_sout/x + _ndst/x) / 2 + append cmds compose [ + pen (col-wire) line-width 2 + line (_sout) (as-pair _smx _sout/y) + (as-pair _smx _ndst/y) (_ndst) + line-width 1 + ] + ] + ] + ] + ; External → SR-left (to-node = structure ID) + if _sw/to-node = _sst/id [ + do [ + _sfound: either block? _sst/shift-regs [find-sr _sst/shift-regs _sw/to-port] [none] + if _sfound [ + _snd: find-node-by-id model/nodes _sw/from-node + if _snd [ + _sout: port-xy _snd _sw/from-port 'out + _sdst: sr-xy _sst _sfound 'left + _smx: to-integer (_sout/x + _sdst/x) / 2 + _scol: sr-type-color _sfound/data-type + append cmds compose [ + pen (_scol) line-width 2 + line (_sout) (as-pair _smx _sout/y) + (as-pair _smx _sdst/y) (_sdst) + line-width 1 + ] + ] + ] + ] + ] + ; SR-right → external (from-node = structure ID) + if _sw/from-node = _sst/id [ + do [ + _sfound: either block? _sst/shift-regs [find-sr _sst/shift-regs _sw/from-port] [none] + if _sfound [ + _snd: none + _snd: find-node-by-id model/nodes _sw/to-node + if _snd [ + _ssrc: sr-xy _sst _sfound 'right + _sin: port-xy _snd _sw/to-port 'in + _smx: to-integer (_ssrc/x + _sin/x) / 2 + _scol: sr-type-color _sfound/data-type + append cmds compose [ + pen (_scol) line-width 2 + line (_ssrc) (as-pair _smx _ssrc/y) + (as-pair _smx _sin/y) (_sin) + line-width 1 + ] + ] + ] + ] + ] + ] + ] + ] + + ; 3) Wire temporal (mientras el usuario elige destino) + if all [model/wire-src model/mouse-pos] [ + src-port-xy: do [ + _sxy: none + ; SR-left virtual (-1) — ▲ borde izquierdo + if all [model/wire-src-struct model/wire-src-sr model/wire-src/id = -1] [ + _sxy: sr-xy model/wire-src-struct model/wire-src-sr 'left + ] + ; SR-right virtual (-2) — ▼ borde derecho + if all [none? _sxy model/wire-src-struct model/wire-src-sr model/wire-src/id = -2] [ + _sxy: sr-xy model/wire-src-struct model/wire-src-sr 'right + ] + ; Iter virtual (-3) — cuadrado [i] + if all [none? _sxy model/wire-src-struct] [ + _st2: model/wire-src-struct + _tx2: struct-terminal-size + _htx2: to-integer (_tx2 / 2) + _sxy: as-pair (to-integer _st2/x + 8 + _htx2) + (to-integer _st2/y + _st2/h - _htx2 - 8) + ] + ; Puerto de nodo normal + if none? _sxy [_sxy: port-xy model/wire-src model/wire-port 'out] + _sxy + ] + append cmds compose [ + pen col-wire line-width 2 + line (src-port-xy) (model/mouse-pos) + ] + ] + + ; 4) Wire roto — error visual de tipos incompatibles + if model/broken-wire [ + append cmds compose [pen 210.30.30 line-width 2] + append cmds draw-dashed-segment model/broken-wire/1 model/broken-wire/2 + mid: as-pair to-integer (model/broken-wire/1/x + model/broken-wire/2/x) / 2 + to-integer (model/broken-wire/1/y + model/broken-wire/2/y) / 2 + append cmds compose [ + pen 210.30.30 line-width 2 + line (as-pair mid/x - 5 mid/y - 5) (as-pair mid/x + 5 mid/y + 5) + line (as-pair mid/x + 5 mid/y - 5) (as-pair mid/x - 5 mid/y + 5) + ] + ] + + ; 5) Nodos normales (encima de las estructuras) + append cmds render-node-list model/nodes model/selected-node + + cmds +] diff --git a/src/ui/diagram/canvas.red b/src/ui/diagram/canvas.red index 728697f..a84cbc5 100644 --- a/src/ui/diagram/canvas.red +++ b/src/ui/diagram/canvas.red @@ -6,927 +6,9 @@ Red [ ; ══════════════════════════════════════════════════════════ ; CONFIG — constantes visuales, sin estado mutable -; ══════════════════════════════════════════════════════════ -block-width: 120 block-height: 50 port-radius: 8 grid-size: 20 - -col-canvas: 225.228.235 -col-grid: 200.203.212 -col-block-ctrl: 50.100.180 -col-block-ind: 175.125.20 -col-block-op: 55.75.105 -col-wire: 195.95.20 -col-wire-bool: 20.160.20 -col-wire-str: 220.100.160 -col-wire-cluster: 139.69.19 -col-wire-sel: 0.160.200 -col-port-in: 50.110.200 -col-port-out: 195.80.25 -col-sel: 0.175.210 -col-text: 240.245.250 -col-black: 0.0.0 - -; Colores de estructuras contenedoras (while-loop) -col-struct-border: 55.80.120 ; borde azulado oscuro -col-struct-bg: 205.210.220 ; fondo ligeramente más oscuro que canvas -col-struct-term-i: 50.100.180 ; terminal iteración (azul como control) -col-struct-term-cond: 20.160.20 ; terminal condición (verde como wire bool) -struct-terminal-size: 14 ; tamaño del cuadrado terminal i y handle resize -sr-terminal-half: 6 ; semitamaño del triángulo SR (triángulo 12px total) - -; Case Structure — dimensiones -case-nav-height: 24 ; altura de la barra de navegación -case-btn-size: 18 ; tamaño de botones ◀ ▶ [+][-] -col-case-nav-bg: 160.185.215 ; fondo de barra de navegación - -; Compensación vertical de texto (8px en Linux por diferencia de baseline) -text-dy: either system/platform = 'Linux [8] [0] - -; ══════════════════════════════════════════════════════════ -; GEOMETRÍA DE NODOS — funciones puras sin side-effects -; ══════════════════════════════════════════════════════════ -; Devuelve el color de un tipo de nodo leyendo la categoría del block-registry. -block-color: func [node-type /local cat] [ - cat: block-category to-word node-type - case [ - cat = 'input [col-block-ctrl] - cat = 'output [col-block-ind] - cat = 'cluster [col-wire-cluster] - true [col-block-op] - ] -] - -; Devuelve los puertos de entrada de un nodo. -; Para bundle: puertos dinámicos desde config/fields. -; Para el resto: consulta el block-registry. -in-ports: func [node] [ - case [ - node/type = 'bundle [cluster-in-ports node] - node/type = 'cluster-indicator [cluster-in-ports node] - true [any [block-in-ports to-word node/type []]] - ] -] - -; Devuelve los puertos de salida de un nodo. -; Para unbundle: puertos dinámicos desde config/fields. -; Para el resto: consulta el block-registry. -out-ports: func [node] [ - case [ - node/type = 'unbundle [cluster-out-ports node] - node/type = 'cluster-control [cluster-out-ports node] - true [any [block-out-ports to-word node/type []]] - ] -] - -; Devuelve el tipo de dato de un puerto de salida ('number por defecto). -; Para unbundle: los puertos de salida son campos dinámicos del cluster. -port-out-type: func [node port-name /local bdef p] [ - if node/type = 'unbundle [return cluster-field-type node to-word port-name] - bdef: find-block to-word node/type - if none? bdef [return 'number] - foreach p bdef/outputs [ - if p/name = to-word port-name [return p/type] - ] - 'number -] - -; Devuelve el tipo de dato de un puerto de entrada ('number por defecto). -; Para bundle: los puertos de entrada son campos dinámicos del cluster. -port-in-type: func [node port-name /local bdef p] [ - if node/type = 'bundle [return cluster-field-type node to-word port-name] - bdef: find-block to-word node/type - if none? bdef [return 'number] - foreach p bdef/inputs [ - if p/name = to-word port-name [return p/type] - ] - 'number -] - -; Devuelve el color de wire para un tipo de dato. -wire-data-color: func [data-type] [ - case [ - data-type = 'boolean [col-wire-bool] - data-type = 'string [col-wire-str] - data-type = 'cluster [col-wire-cluster] - data-type = 'array [col-wire] ; mismo naranja que number, diferenciado por línea doble - true [col-wire] - ] -] - -; Devuelve la posición del terminal SR (▲ borde izquierdo o ▼ borde derecho). -sr-xy: func [st sr side] [ - either side = 'left [ - as-pair st/x (to-integer st/y + sr/y-offset) - ][ - as-pair (to-integer st/x + st/w) (to-integer st/y + sr/y-offset) - ] -] - -; Devuelve el color del terminal SR según su data-type. -sr-type-color: func [data-type] [ - case [ - data-type = 'boolean [col-wire-bool] - data-type = 'string [col-wire-str] - data-type = 'array [col-wire] - true [col-wire] - ] -] - -; Busca un SR por nombre en un bloque de shift-regs. -; Usa while/pick para evitar problemas de posición de serie con foreach. -find-sr: func [shift-regs [block!] port-name [word!] /local k sr] [ - k: 1 - while [k <= length? shift-regs] [ - sr: pick shift-regs k - if (to-word sr/name) = port-name [return sr] - k: k + 1 - ] - none -] - -; Genera comandos Draw para una línea daseada horizontal o vertical. -; Simula el patrón característico del wire string (visual-spec §4.2). -draw-dashed-segment: func [p1 [pair!] p2 [pair!] /local cmds dash gap pos end-v horiz] [ - cmds: copy [] - dash: 5 gap: 3 - horiz: p1/y = p2/y - either horiz [ - pos: p1/x end-v: p2/x - if pos > end-v [pos: p2/x end-v: p1/x] - while [pos < end-v] [ - append cmds compose [ - line (as-pair pos p1/y) (as-pair (min pos + dash end-v) p1/y) - ] - pos: pos + dash + gap - ] - ][ - pos: p1/y end-v: p2/y - if pos > end-v [pos: p2/y end-v: p1/y] - while [pos < end-v] [ - append cmds compose [ - line (as-pair p1/x pos) (as-pair p1/x (min pos + dash end-v)) - ] - pos: pos + dash + gap - ] - ] - cmds -] - -port-xy: func [node port-name direction /local ports port-index found] [ - either direction = 'in [ - ports: in-ports node - found: find ports port-name - port-index: either found [index? found] [1] - as-pair (node/x - port-radius) (node/y + 12 + ((port-index - 1) * 20)) - ][ - ports: out-ports node - found: find ports port-name - port-index: either found [index? found] [1] - as-pair (node/x + block-width + port-radius) (node/y + 12 + ((port-index - 1) * 20)) - ] -] - -; Devuelve la altura visual de un nodo. -; bundle/unbundle/cluster-control/cluster-indicator: variable según número de campos. -; Resto: block-height fijo. -node-height: func [node /local n-in n-out] [ - case [ - find [bundle unbundle cluster-control cluster-indicator] node/type [ - n-in: length? in-ports node - n-out: length? out-ports node - max block-height (12 + (max n-in n-out) * 20 + 10) - ] - true [block-height] - ] -] - -; ══════════════════════════════════════════════════════════ -; MODELO — todo el estado mutable vive aquí -; ══════════════════════════════════════════════════════════ -; make-diagram-model movida a model.red (4A refactor) - -gen-node-id: func [model /local next-id] [ - next-id: model/next-id - model/next-id: model/next-id + 1 - next-id -] - -; ══════════════════════════════════════════════════════════ -; RENDER — funciones puras que reciben modelo y devuelven -; bloques de primitivas Draw -; ══════════════════════════════════════════════════════════ -render-grid: func [canvas-width canvas-height /local cmds x y] [ - cmds: compose [pen (col-grid) fill-pen (col-grid) line-width 1] - x: grid-size - while [x < canvas-width] [ - y: grid-size - while [y < canvas-height] [ - append cmds compose [circle (as-pair x y) 1] - y: y + grid-size - ] - x: x + grid-size - ] - cmds -] - -; ── Helpers de render: reutilizables por render-bd y render-structure ──────── - -render-wire-list: func [ - "Genera Draw cmds para una lista de wires dado su lista de nodos fuente" - wires nodes selected-wire - /local cmds wire src-node dst-node out-xy in-xy mid-x wire-dtype wire-color node -][ - cmds: copy [] - foreach wire wires [ - src-node: find-node-by-id nodes wire/from-node - dst-node: find-node-by-id nodes wire/to-node - if all [src-node dst-node] [ - out-xy: port-xy src-node wire/from-port 'out - in-xy: port-xy dst-node wire/to-port 'in - mid-x: to-integer (out-xy/x + in-xy/x) / 2 - wire-dtype: port-out-type src-node wire/from-port - wire-color: either same? wire selected-wire [col-wire-sel] [wire-data-color wire-dtype] - case [ - all [wire-dtype = 'string not same? wire selected-wire] [ - append cmds compose [pen (wire-color) line-width 2] - append cmds draw-dashed-segment out-xy as-pair mid-x out-xy/y - append cmds draw-dashed-segment as-pair mid-x out-xy/y as-pair mid-x in-xy/y - append cmds draw-dashed-segment as-pair mid-x in-xy/y in-xy - ] - all [wire-dtype = 'array not same? wire selected-wire] [ - ; Línea doble: trazo grueso exterior + trazo fino interior del color del canvas - append cmds compose [ - pen (wire-color) line-width 4 - line (out-xy) (as-pair mid-x out-xy/y) (as-pair mid-x in-xy/y) (in-xy) - pen col-canvas line-width 1 - line (out-xy) (as-pair mid-x out-xy/y) (as-pair mid-x in-xy/y) (in-xy) - ] - ] - true [ - append cmds compose [ - pen (wire-color) line-width 2 - line (out-xy) (as-pair mid-x out-xy/y) (as-pair mid-x in-xy/y) (in-xy) - ] - ] - ] - ] - ] - cmds -] - -render-node-list: func [ - "Genera Draw cmds para una lista de nodos" - nodes selected-node - /local cmds node node-color type-label ports in-port-y out-port-y port -][ - cmds: copy [] - foreach node nodes [ - ; bundle/unbundle/cluster-control/cluster-indicator tienen render propio (altura variable, puertos dinámicos) - if find [bundle unbundle cluster-control cluster-indicator] node/type [ - append cmds render-cluster-node node selected-node - continue - ] - node-color: block-color node/type - append cmds compose [ - pen (node-color - 20.20.20) line-width 1 fill-pen (node-color) - box (as-pair node/x node/y) (as-pair (node/x + block-width) (node/y + block-height)) 5 - ] - append cmds compose [ - pen off fill-pen (node-color + 30.30.30) - box (as-pair node/x node/y) (as-pair (node/x + 4) (node/y + block-height)) 0 - ] - type-label: switch/default node/type [ - control ["DBL"] - indicator ["DBL"] - add ["ADD +"] - sub ["SUB -"] - mul ["MUL *"] - div ["DIV /"] - display ["DISP"] - subvi ["SUBVI"] - const [form any [select node/config 'default 0.0]] - bool-const [either any [select node/config 'default false] ["T"] ["F"]] - bool-control ["TF"] - bool-indicator ["TF"] - and-op ["AND"] - or-op ["OR"] - not-op ["NOT"] - gt-op [">"] - lt-op ["<"] - eq-op ["="] - str-const [any [select node/config 'default ""]] - str-control [to-string any [select node/config 'default "STR"]] - str-indicator ["STR"] - concat ["CONCAT"] - str-length ["LEN"] - to-string ["→STR"] - arr-const [rejoin ["[" form any [select node/config 'default copy []] "]"]] - arr-control ["ARR"] - arr-indicator ["ARR"] - build-array ["BUILD[]"] - index-array ["IDX[]"] - array-size ["SIZE[]"] - array-subset ["SUB[]"] - ] [uppercase form node/type] - either all [node/label object? node/label node/label/visible] [ - append cmds compose [ - fill-pen col-text - text (as-pair (node/x + 10) (node/y + 10 + text-dy)) (any [node/label/text ""]) - text (as-pair (node/x + 10) (node/y + 26 + text-dy)) (type-label) - ] - ][ - either all [node/label string? node/label] [ - append cmds compose [ - fill-pen col-text - text (as-pair (node/x + 10) (node/y + 10 + text-dy)) (node/label) - text (as-pair (node/x + 10) (node/y + 26 + text-dy)) (type-label) - ] - ][ - append cmds compose [ - fill-pen col-text - text (as-pair (node/x + 10) (node/y + 14 + text-dy)) (type-label) - ] - ] - ] - ports: in-ports node - in-port-y: node/y + 12 - foreach port ports [ - append cmds compose [ - pen col-port-in fill-pen col-port-in - circle (as-pair (node/x - port-radius) in-port-y) (port-radius) - fill-pen col-text - text (as-pair (node/x - port-radius - 22) (in-port-y - 7 + text-dy)) (form port) - ] - in-port-y: in-port-y + 20 - ] - ports: out-ports node - out-port-y: node/y + 12 - foreach port ports [ - append cmds compose [ - pen col-port-out fill-pen col-port-out - circle (as-pair (node/x + block-width + port-radius) out-port-y) (port-radius) - fill-pen col-text - text (as-pair (node/x + block-width + port-radius + 12) (out-port-y - 7 + text-dy)) (form port) - ] - out-port-y: out-port-y + 20 - ] - if same? node selected-node [ - append cmds compose [ - pen col-sel line-width 2 fill-pen off - box (as-pair (node/x - 3) (node/y - 3)) (as-pair (node/x + block-width + 3) (node/y + block-height + 3)) 6 - line-width 1 - ] - ] - ] - cmds -] - -; ══════════════════════════════════════════════════════════ -; RENDER-CLUSTER-NODE — Bundle / Unbundle con puertos dinámicos -; ══════════════════════════════════════════════════════════ - -render-cluster-node: func [ - "Genera Draw cmds para un nodo bundle/unbundle con altura variable y puertos coloreados" - node selected-node - /local cmds node-color h type-label ports in-port-y out-port-y port port-col -][ - cmds: copy [] - node-color: col-wire-cluster - h: node-height node - - ; Cuerpo del nodo (altura variable) - append cmds compose [ - pen (node-color - 20.20.20) line-width 1 fill-pen (node-color) - box (as-pair node/x node/y) (as-pair (node/x + block-width) (node/y + h)) 5 - pen off fill-pen (node-color + 30.30.30) - box (as-pair node/x node/y) (as-pair (node/x + 4) (node/y + h)) 0 - ] - - ; Etiqueta de tipo centrada verticalmente - type-label: case [ - node/type = 'bundle ["BUNDLE"] - node/type = 'unbundle ["UNBUNDLE"] - node/type = 'cluster-control ["CLU-CTRL"] - true ["CLU-IND"] - ] - append cmds compose [ - fill-pen col-text - text (as-pair (node/x + 8) (node/y + 14 + text-dy)) (type-label) - ] - - ; Puertos de entrada (coloreados por tipo de campo) - ports: in-ports node - in-port-y: node/y + 12 - foreach port ports [ - port-col: wire-data-color port-in-type node port - append cmds compose [ - pen (port-col) fill-pen (port-col) - circle (as-pair (node/x - port-radius) in-port-y) (port-radius) - fill-pen col-text - text (as-pair (node/x - port-radius - 22) (in-port-y - 7)) (form port) - ] - in-port-y: in-port-y + 20 - ] - - ; Puertos de salida (coloreados por tipo de campo o cluster) - ports: out-ports node - out-port-y: node/y + 12 - foreach port ports [ - port-col: wire-data-color port-out-type node port - append cmds compose [ - pen (port-col) fill-pen (port-col) - circle (as-pair (node/x + block-width + port-radius) out-port-y) (port-radius) - fill-pen col-text - text (as-pair (node/x + block-width + port-radius + 12) (out-port-y - 7)) (form port) - ] - out-port-y: out-port-y + 20 - ] - - ; Borde de selección - if same? node selected-node [ - append cmds compose [ - pen col-sel line-width 2 fill-pen off - box (as-pair (node/x - 3) (node/y - 3)) (as-pair (node/x + block-width + 3) (node/y + h + 3)) 6 - line-width 1 - ] - ] - cmds -] - -; ══════════════════════════════════════════════════════════ -; RENDER-CASE-STRUCTURE — Case Structure con múltiples frames -; ══════════════════════════════════════════════════════════ - -render-case-structure: func [ - "Genera Draw cmds para una Case Structure con barra de navegación" - st model - /local cmds bx by bx2 by2 nav-h act-frame frame-label sel-x -][ - cmds: copy [] - bx: st/x by: st/y bx2: st/x + st/w by2: st/y + st/h - nav-h: case-nav-height - - ; 1) Fondo + borde del contenedor - append cmds compose [ - pen (col-struct-border) line-width 2 fill-pen (col-struct-bg) - box (as-pair bx by) (as-pair bx2 by2) 8 - line-width 1 - ] - - ; 2) Barra de navegación (fondo más oscuro) - append cmds compose [ - pen (col-struct-border) fill-pen (col-case-nav-bg) - box (as-pair (bx + 2) (by + 2)) (as-pair (bx2 - 2) (by + nav-h)) 4 - ] - - ; 3) Label "Case Structure" - if all [st/label object? st/label] [ - append cmds compose [ - pen off fill-pen col-black - text (as-pair (bx + 8) (by + 5 + text-dy)) (st/label/text) - ] - ] - - ; 4) Botones de navegación ◀ ▶ [+][-] - ; ◀ (izquierda) en x: bx+8 - append cmds compose [ - pen (col-struct-border) line-width 1 fill-pen (col-struct-bg + 30.30.30) - box (as-pair (bx + 8) (by + 4)) (as-pair (bx + 26) (by + 22)) 2 - fill-pen (col-black) - text (as-pair (bx + 13) (by + 4 + text-dy)) "<" - ] - ; ▶ (derecha) en x: bx+28 - append cmds compose [ - pen (col-struct-border) line-width 1 fill-pen (col-struct-bg + 30.30.30) - box (as-pair (bx + 28) (by + 4)) (as-pair (bx + 46) (by + 22)) 2 - fill-pen (col-black) - text (as-pair (bx + 33) (by + 4 + text-dy)) ">" - ] - - ; 5) Indicador de frame activo - act-frame: either all [block? st/frames st/active-frame < length? st/frames] [ - st/frames/(st/active-frame + 1) - ][ - none - ] - frame-label: either act-frame [act-frame/label] ["?"] - append cmds compose [ - fill-pen (col-black) - text (as-pair (bx + 52) (by + 5 + text-dy)) (frame-label) - ] - - ; 6) Botones [+][-] en esquina derecha de la barra - ; [+] en x: bx2-48 - append cmds compose [ - pen (col-struct-border) line-width 1 fill-pen (col-struct-bg + 20.20.20) - box (as-pair (bx2 - 48) (by + 4)) (as-pair (bx2 - 30) (by + 22)) 2 - fill-pen (col-black) - text (as-pair (bx2 - 43) (by + 4 + text-dy)) "+" - ] - ; [-] en x: bx2-26 - append cmds compose [ - pen (col-struct-border) line-width 1 fill-pen (col-struct-bg + 20.20.20) - box (as-pair (bx2 - 26) (by + 4)) (as-pair (bx2 - 8) (by + 22)) 2 - fill-pen (col-black) - text (as-pair (bx2 - 20) (by + 4 + text-dy)) "-" - ] - - ; 7) Terminal selector [?] — esquina superior izquierda debajo de la barra - ; (número entero = naranja, booleano = verde) - sel-x: bx + 8 - append cmds compose [ - pen (col-struct-border) line-width 1 fill-pen (col-wire) - box (as-pair sel-x (by + nav-h + 4)) - (as-pair (sel-x + 14) (by + nav-h + 18)) 2 - fill-pen (col-black) - text (as-pair (sel-x + 3) (by + nav-h + 3 + text-dy)) "?" - ] - - ; 8) Handle de resize — esquina inferior-derecha 10x10 - append cmds compose [ - pen col-struct-border line-width 1 fill-pen (col-struct-border + 40.40.40) - box (as-pair (bx2 - 10) (by2 - 10)) (as-pair bx2 by2) 0 - ] - - ; 9) Borde de selección cian - if all [same? st model/selected-struct none? model/selected-node] [ - append cmds compose [ - pen col-sel line-width 2 fill-pen off - box (as-pair (bx - 3) (by - 3)) (as-pair (bx2 + 3) (by2 + 3)) 10 - line-width 1 - ] - ] - - ; 10) Wire del selector (si hay selector-wire) - if st/selector-wire [ - do [ - sel-src: none - sel-src: find-node-by-id model/nodes st/selector-wire/from - if sel-src [ - src-xy: port-xy sel-src st/selector-wire/port 'out - dst-xy: as-pair (sel-x + 7) (by + nav-h + 11) - mid-cx: to-integer (src-xy/x + dst-xy/x) / 2 - ; Color según tipo: detectado del wire conectado - append cmds compose [ - pen (col-wire) line-width 2 - line (src-xy) (as-pair mid-cx src-xy/y) (as-pair mid-cx dst-xy/y) (dst-xy) - line-width 1 - ] - ] - ] - ] - - ; 11) Renderizar nodos y wires del frame activo - if act-frame [ - append cmds render-node-list act-frame/nodes model/selected-node - append cmds render-wire-list act-frame/wires act-frame/nodes model/selected-wire - ] - - cmds -] - -render-structure: func [ - "Genera Draw cmds para una estructura contenedora (while-loop, for-loop, case-structure)" - st model - /local cmds bx by bx2 by2 tx sr sr-col y-off _w _sr-has-ext-wire - _sr-found _src-xy _in-xy _out-xy _dst-xy _mid-x _sr-col2 -][ - ; Bifurcación: Case Structure tiene renderizado propio - if st/type = 'case-structure [ - return render-case-structure st model - ] - - ; ── WHILE/FOR LOOP ───────────────────────────────────── - cmds: copy [] - bx: st/x by: st/y bx2: st/x + st/w by2: st/y + st/h - tx: struct-terminal-size - - ; 1) Fondo + borde del contenedor - append cmds compose [ - pen (col-struct-border) line-width 2 fill-pen (col-struct-bg) - box (as-pair bx by) (as-pair bx2 by2) 8 - line-width 1 - ] - - ; 2) Label arriba-izquierda - if all [st/label object? st/label] [ - append cmds compose [ - pen off fill-pen (col-struct-border) - text (as-pair (bx + 8) (by + 6 + text-dy)) (st/label/text) - ] - ] - - ; 3) Terminal iteración [i] — cuadrado azul abajo-izquierda - append cmds compose [ - pen (col-struct-border) line-width 1 fill-pen (col-struct-term-i) - box (as-pair (bx + 8) (by2 - tx - 8)) - (as-pair (bx + 8 + tx) (by2 - 8)) 2 - pen off fill-pen col-text - text (as-pair (bx + 11) (by2 - tx - 5 + text-dy)) "i" - ] - - ; 4) Terminal condición [●] — círculo verde abajo-derecha (solo while-loop) - ; Desplazado a bx2-24, by2-24 para no solapar con el handle de resize (14x14) - if st/type = 'while-loop [ - append cmds compose [ - pen (col-struct-border) line-width 1 fill-pen (col-struct-term-cond) - circle (as-pair (bx2 - 24) (by2 - 24)) 8 - ] - ] - - ; 4b) Terminal count [N] — cuadrado naranja arriba-izquierda (solo for-loop) - if st/type = 'for-loop [ - append cmds compose [ - pen (col-struct-border) line-width 1 fill-pen (col-wire) - box (as-pair (bx + 8) (by + 8)) - (as-pair (bx + 8 + tx) (by + 8 + tx)) 2 - pen off fill-pen col-text - text (as-pair (bx + 11) (by + 11 + text-dy)) "N" - ] - ] - - ; 5) Terminales shift register — ▲ borde izquierdo, ▼ borde derecho - if block? st/shift-regs [ - foreach sr head st/shift-regs [ - sr-col: sr-type-color sr/data-type - y-off: sr/y-offset - append cmds compose [ - pen (col-struct-border) line-width 1 fill-pen (sr-col) - ; ▲ izquierdo (lectura — valor entra al loop) - triangle (as-pair (bx - sr-terminal-half) (by + y-off + sr-terminal-half)) - (as-pair (bx + sr-terminal-half) (by + y-off + sr-terminal-half)) - (as-pair bx (by + y-off - sr-terminal-half)) - ; ▼ derecho (escritura — valor sale del loop) - triangle (as-pair (bx2 - sr-terminal-half) (by + y-off - sr-terminal-half)) - (as-pair (bx2 + sr-terminal-half) (by + y-off - sr-terminal-half)) - (as-pair bx2 (by + y-off + sr-terminal-half)) - ] - ; Texto init-value junto al ▲ — solo si no hay wire externo conectado a este SR - _sr-has-ext-wire: false - foreach _w model/wires [ - if all [_w/to-node = st/id (to-word _w/to-port) = to-word sr/name] [ - _sr-has-ext-wire: true - ] - ] - unless _sr-has-ext-wire [ - append cmds compose [ - pen off fill-pen (col-struct-border) - text (as-pair (bx + 10) (by + y-off - 7 + text-dy)) (form sr/init-value) - ] - ] - ] - ] - - ; 6) Handle de resize — cuadrado 10x10 esquina inferior-derecha - append cmds compose [ - pen col-struct-border line-width 1 fill-pen (col-struct-border + 40.40.40) - box (as-pair (bx2 - 10) (by2 - 10)) (as-pair bx2 by2) 0 - ] - - ; 7) Borde de selección cian — solo cuando la estructura en sí está seleccionada - ; (no cuando se ha seleccionado un nodo interno) - if all [same? st model/selected-struct none? model/selected-node] [ - append cmds compose [ - pen col-sel line-width 2 fill-pen off - box (as-pair (bx - 3) (by - 3)) (as-pair (bx2 + 3) (by2 + 3)) 10 - line-width 1 - ] - ] - - ; 7b) Highlight del SR seleccionado — círculos cian en ambos triángulos - if all [model/selected-sr same? st model/selected-sr/1] [ - do [ - _sel-sr: model/selected-sr/2 - _sel-y: to-integer by + _sel-sr/y-offset - append cmds compose [ - pen col-sel line-width 2 fill-pen off - circle (as-pair bx _sel-y) (sr-terminal-half + 4) - circle (as-pair bx2 _sel-y) (sr-terminal-half + 4) - line-width 1 - ] - ] - ] - - ; 8) Wires desde terminales virtuales: iter (-3), SR-left (-1), SR-right (-2) - do [ - half-tx: to-integer (tx / 2) ; 14/2 = 7 — precomputado para evitar precedencia - iter-src: as-pair (to-integer bx + 8 + half-tx) (to-integer by2 - half-tx - 8) - foreach w st/wires [ - ; Iter (-3) → nodo interno - if w/from-node = -3 [ - nd: find-node-by-id st/nodes w/to-node - if nd [ - in-xy: port-xy nd w/to-port 'in - mid-x: to-integer (iter-src/x + in-xy/x) / 2 - append cmds compose [ - pen col-wire line-width 2 - line (iter-src) (as-pair mid-x iter-src/y) - (as-pair mid-x in-xy/y) (in-xy) - line-width 1 - ] - ] - ] - ; SR-left (-1) → nodo interno - if w/from-node = -1 [ - _sr-found: find-sr st/shift-regs w/from-port - if _sr-found [ - nd: find-node-by-id st/nodes w/to-node - if nd [ - _src-xy: sr-xy st _sr-found 'left - _in-xy: port-xy nd w/to-port 'in - _mid-x: to-integer (_src-xy/x + _in-xy/x) / 2 - _sr-col2: sr-type-color _sr-found/data-type - append cmds compose [ - pen (_sr-col2) line-width 2 - line (_src-xy) (as-pair _mid-x _src-xy/y) - (as-pair _mid-x _in-xy/y) (_in-xy) - line-width 1 - ] - ] - ] - ] - ; Nodo interno → SR-right (-2) - if w/to-node = -2 [ - _sr-found: find-sr st/shift-regs w/to-port - if _sr-found [ - nd: find-node-by-id st/nodes w/from-node - if nd [ - _out-xy: port-xy nd w/from-port 'out - _dst-xy: sr-xy st _sr-found 'right - _mid-x: to-integer (_out-xy/x + _dst-xy/x) / 2 - _sr-col2: sr-type-color _sr-found/data-type - append cmds compose [ - pen (_sr-col2) line-width 2 - line (_out-xy) (as-pair _mid-x _out-xy/y) - (as-pair _mid-x _dst-xy/y) (_dst-xy) - line-width 1 - ] - ] - ] - ] - ] - ] - - ; 9) Wires internos normales (entre nodos reales) - append cmds render-wire-list st/wires st/nodes model/selected-wire - - ; 10) Nodos internos - append cmds render-node-list st/nodes model/selected-node - - ; 11) Wire de condición — línea desde el nodo fuente hasta el terminal ● - if st/cond-wire [ - do [ - cond-src: none - cond-src: find-node-by-id st/nodes st/cond-wire/from - if cond-src [ - src-xy: port-xy cond-src st/cond-wire/port 'out - dst-xy: as-pair (bx2 - 24) (by2 - 24) - mid-cx: to-integer (src-xy/x + dst-xy/x) / 2 - append cmds compose [ - pen (col-wire-bool) line-width 2 - line (src-xy) (as-pair mid-cx src-xy/y) (as-pair mid-cx dst-xy/y) (dst-xy) - ] - ] - ] - ] - - cmds -] - -render-bd: func [model /local cmds src-port-xy mid st] [ - cmds: copy [] - - ; 0) Grid de fondo - append cmds render-grid 880 490 - - ; 1) Estructuras contenedoras (detrás de los nodos normales) - if block? model/structures [ - foreach st model/structures [ - append cmds render-structure st model - ] - ] - - ; 2) Wires permanentes normales - append cmds render-wire-list model/wires model/nodes model/selected-wire - - ; 2b) Wires externos de shift registers (ext→▲ y ▼→ext) y wire N de for-loop - if block? model/structures [ - foreach _sst model/structures [ - foreach _sw model/wires [ - ; For-loop: External → [N] (to-node = structure ID, to-port = "count") - if all [_sst/type = 'for-loop _sw/to-node = _sst/id _sw/to-port = 'count] [ - do [ - _snd: none - _snd: find-node-by-id model/nodes _sw/from-node - if _snd [ - _sout: port-xy _snd _sw/from-port 'out - _htx: to-integer (struct-terminal-size / 2) - _ndst: as-pair (to-integer _sst/x + 8 + _htx) - (to-integer _sst/y + 8 + _htx) - _smx: to-integer (_sout/x + _ndst/x) / 2 - append cmds compose [ - pen (col-wire) line-width 2 - line (_sout) (as-pair _smx _sout/y) - (as-pair _smx _ndst/y) (_ndst) - line-width 1 - ] - ] - ] - ] - ; External → SR-left (to-node = structure ID) - if _sw/to-node = _sst/id [ - do [ - _sfound: either block? _sst/shift-regs [find-sr _sst/shift-regs _sw/to-port] [none] - if _sfound [ - _snd: find-node-by-id model/nodes _sw/from-node - if _snd [ - _sout: port-xy _snd _sw/from-port 'out - _sdst: sr-xy _sst _sfound 'left - _smx: to-integer (_sout/x + _sdst/x) / 2 - _scol: sr-type-color _sfound/data-type - append cmds compose [ - pen (_scol) line-width 2 - line (_sout) (as-pair _smx _sout/y) - (as-pair _smx _sdst/y) (_sdst) - line-width 1 - ] - ] - ] - ] - ] - ; SR-right → external (from-node = structure ID) - if _sw/from-node = _sst/id [ - do [ - _sfound: either block? _sst/shift-regs [find-sr _sst/shift-regs _sw/from-port] [none] - if _sfound [ - _snd: none - _snd: find-node-by-id model/nodes _sw/to-node - if _snd [ - _ssrc: sr-xy _sst _sfound 'right - _sin: port-xy _snd _sw/to-port 'in - _smx: to-integer (_ssrc/x + _sin/x) / 2 - _scol: sr-type-color _sfound/data-type - append cmds compose [ - pen (_scol) line-width 2 - line (_ssrc) (as-pair _smx _ssrc/y) - (as-pair _smx _sin/y) (_sin) - line-width 1 - ] - ] - ] - ] - ] - ] - ] - ] - - ; 3) Wire temporal (mientras el usuario elige destino) - if all [model/wire-src model/mouse-pos] [ - src-port-xy: do [ - _sxy: none - ; SR-left virtual (-1) — ▲ borde izquierdo - if all [model/wire-src-struct model/wire-src-sr model/wire-src/id = -1] [ - _sxy: sr-xy model/wire-src-struct model/wire-src-sr 'left - ] - ; SR-right virtual (-2) — ▼ borde derecho - if all [none? _sxy model/wire-src-struct model/wire-src-sr model/wire-src/id = -2] [ - _sxy: sr-xy model/wire-src-struct model/wire-src-sr 'right - ] - ; Iter virtual (-3) — cuadrado [i] - if all [none? _sxy model/wire-src-struct] [ - _st2: model/wire-src-struct - _tx2: struct-terminal-size - _htx2: to-integer (_tx2 / 2) - _sxy: as-pair (to-integer _st2/x + 8 + _htx2) - (to-integer _st2/y + _st2/h - _htx2 - 8) - ] - ; Puerto de nodo normal - if none? _sxy [_sxy: port-xy model/wire-src model/wire-port 'out] - _sxy - ] - append cmds compose [ - pen col-wire line-width 2 - line (src-port-xy) (model/mouse-pos) - ] - ] - - ; 4) Wire roto — error visual de tipos incompatibles - if model/broken-wire [ - append cmds compose [pen 210.30.30 line-width 2] - append cmds draw-dashed-segment model/broken-wire/1 model/broken-wire/2 - mid: as-pair to-integer (model/broken-wire/1/x + model/broken-wire/2/x) / 2 - to-integer (model/broken-wire/1/y + model/broken-wire/2/y) / 2 - append cmds compose [ - pen 210.30.30 line-width 2 - line (as-pair mid/x - 5 mid/y - 5) (as-pair mid/x + 5 mid/y + 5) - line (as-pair mid/x + 5 mid/y - 5) (as-pair mid/x - 5 mid/y + 5) - ] - ] - ; 5) Nodos normales (encima de las estructuras) - append cmds render-node-list model/nodes model/selected-node +#include %canvas-render.red - cmds -] ; ══════════════════════════════════════════════════════════ ; HIT-TEST — funciones puras, reciben modelo y coordenadas @@ -1275,389 +357,9 @@ hit-wire: func [model mouse-x mouse-y /local w st frame] [ ; Alterna el valor booleano de un nodo bool-const. ; node/config es un bloque de pares [clave valor ...]. -toggle-bool-const: func [node /local cur] [ - cur: any [select node/config 'default false] - set-config node 'default not cur -] - -; Abre diálogo para editar el valor de una constante numérica. -; Patrón view/no-wait con vars de módulo (igual que rename-dialog). -open-const-edit-dialog: func [node canvas-face /local cur-val] [ - cur-val: any [select node/config 'default 0.0] - const-dialog-node: node - const-dialog-canvas: canvas-face - const-dialog-field: none - view/no-wait compose [ - title "Editar constante" - text "Valor:" return - const-dialog-field: field 150 (form cur-val) - on-enter [ - apply-const-value const-dialog-node const-dialog-field/text - const-dialog-canvas/draw: render-bd const-dialog-canvas/extra - unview - ] - return - button "OK" [ - apply-const-value const-dialog-node const-dialog-field/text - const-dialog-canvas/draw: render-bd const-dialog-canvas/extra - unview - ] - button "Cancelar" [unview] - ] -] - -; Actualiza node/config 'default con el nuevo valor numérico. -apply-const-value: func [node new-text /local val] [ - val: attempt [to-float new-text] - if none? val [exit] - set-config node 'default val -] - -; Aplica valor string a un nodo y refresca el canvas. -; Función auxiliar para evitar set-path con valor literal en compose/deep. -str-apply-and-refresh: func [nd txt cnv] [ - apply-str-value nd txt - cnv/draw: render-bd cnv/extra -] -; Abre diálogo para editar el valor de una constante o control string. -; Usa compose/deep para incrustar node y canvas-face directamente en los handlers, -; evitando el bug de variables de módulo compartidas cuando dos diálogos están abiertos. -open-str-edit-dialog: func [node canvas-face /local cur-val] [ - cur-val: copy any [select node/config 'default ""] - view/no-wait compose/deep [ - title "Editar string" - text "Valor:" return - field 200 (cur-val) - on-enter [ - ; face = el field (on-enter se dispara en el field) - str-apply-and-refresh (node) copy face/text (canvas-face) - unview - ] - return - button "OK" [ - ; Buscar el field en los panes del panel padre - foreach pf face/parent/pane [ - if pf/type = 'field [ - str-apply-and-refresh (node) copy pf/text (canvas-face) - break - ] - ] - unview - ] - button "Cancelar" [unview] - ] -] - -; Actualiza node/config 'default con el nuevo valor string. -apply-str-value: func [node new-text] [ - set-config node 'default new-text -] - -; Actualiza node/config 'default con un block! de valores numéricos parseados desde texto. -; El usuario introduce valores separados por espacios, ej: "1.0 2.0 3.0" -apply-arr-value: func [node new-text /local vals tok parsed-block] [ - parsed-block: copy [] - vals: split trim new-text " " - foreach tok vals [ - tok: trim tok - if not empty? tok [ - append parsed-block any [attempt [to-float tok] attempt [to-integer tok] 0.0] - ] - ] - set-config node 'default parsed-block -] - -arr-apply-and-refresh: func [nd txt cnv] [ - apply-arr-value nd txt - cnv/draw: render-bd cnv/extra -] - -; Abre diálogo para editar el valor de un array constante. -; El usuario introduce números separados por espacios: "1.0 2.0 3.0" -open-arr-edit-dialog: func [node canvas-face /local cur-val cur-text] [ - cur-val: any [select node/config 'default copy []] - cur-text: form cur-val ; "1.0 2.0 3.0" - view/no-wait compose/deep [ - title "Editar array" - text "Valores (separados por espacios):" return - field 250 (cur-text) - on-enter [ - arr-apply-and-refresh (node) copy face/text (canvas-face) - unview - ] - return - button "OK" [ - foreach pf face/parent/pane [ - if pf/type = 'field [ - arr-apply-and-refresh (node) copy pf/text (canvas-face) - break - ] - ] - unview - ] - button "Cancelar" [unview] - ] -] - -apply-rename-label: func [node new-text] [ - either empty? new-text [ - if all [node/label object? node/label] [ - node/label/visible: false - ] - ][ - either all [node/label object? node/label] [ - node/label/text: new-text - node/label/visible: true - ][ - node/label: new-text - ] - ] -] - -; ── Cluster edit dialog ────────────────────────────────────────────────── - -; Guarda la lista de campos en node/config/fields. -apply-cluster-fields: func [node fields-block] [ - set-config node 'fields fields-block -] - -; Parsea el texto del área de edición ("nombre:tipo" por línea) a [nombre 'tipo ...]. -parse-cluster-fields-text: func [text /local result lines parts fname ftype] [ - result: copy [] - foreach line split text "^/" [ - line: trim line - if not empty? line [ - parts: split line ":" - if (length? parts) >= 2 [ - fname: to-word trim parts/1 - ftype: to-word trim parts/2 - unless find [number boolean string] ftype [ftype: 'number] - append result fname - append result to lit-word! ftype - ] - ] - ] - result -] - -; Aplica campos parseados y refresca el canvas. -cluster-apply-and-refresh: func [nd txt cnv] [ - apply-cluster-fields nd parse-cluster-fields-text txt - cnv/draw: render-bd cnv/extra - show cnv -] - -; Vars de módulo para el diálogo de edición de cluster (mismo patrón que rename) -cluster-dialog-node: none -cluster-dialog-canvas: none -cluster-dialog-area: none - -; Abre diálogo para editar los campos de un bundle/unbundle. -; El usuario introduce campos en formato "nombre:tipo", uno por línea. -open-cluster-edit-dialog: func [node canvas-face /local cur-fields cur-text] [ - cluster-dialog-node: node - cluster-dialog-canvas: canvas-face - cluster-dialog-area: none - cur-fields: cluster-fields node - cur-text: copy "" - foreach [fn ft] cur-fields [ - append cur-text rejoin [form fn ":" form to-word ft "^/"] - ] - view/no-wait compose/deep [ - title "Editar campos del cluster" - text {Formato: nombre:tipo (uno por línea)} return - text {Tipos: number boolean string} return - cluster-dialog-area: area 260x180 (cur-text) - return - button "OK" [ - cluster-apply-and-refresh (node) copy cluster-dialog-area/text (canvas-face) - unview - ] - button "Cancelar" [unview] - ] -] - -; Estado del diálogo de renombrado (view/no-wait requiere vars de módulo -; porque la función retorna antes de que el usuario cierre el diálogo). -rename-dialog-node: none -rename-dialog-canvas: none -rename-dialog-field: none - -; Estado del diálogo de edición de constante numérica (mismo patrón) -const-dialog-node: none -const-dialog-canvas: none -const-dialog-field: none - -; ── Paleta de bloques ──────────────────────────────────────────── -; vars de módulo para el diálogo de paleta (mismo patrón que rename) -palette-canvas: none -palette-pos-x: 0 -palette-pos-y: 0 -palette-struct: none ; none = añadir a model/nodes, structure = añadir a st/nodes - -; Añade un nodo al destino correcto: estructura interna o diagrama principal. -palette-add-node: func [node-type /local n nid model] [ - model: palette-canvas/extra - nid: gen-node-id model - n: make-node compose [id: (nid) type: (node-type) x: (palette-pos-x) y: (palette-pos-y)] - either palette-struct [ - ; Case structure: añadir al frame activo - if all [palette-struct/type = 'case-structure block? palette-struct/frames] [ - if palette-struct/active-frame < length? palette-struct/frames [ - append palette-struct/frames/(palette-struct/active-frame + 1)/nodes n - ] - ] - ; While/For loop: añadir a st/nodes - if find [while-loop for-loop] palette-struct/type [ - append palette-struct/nodes n - ] - ][ - append model/nodes n - ] - palette-canvas/draw: render-bd model - show palette-canvas - unview -] - -; Crea una nueva estructura while-loop y la añade al diagrama. -palette-add-structure: func [type [word!] /local nid st model] [ - model: palette-canvas/extra - nid: gen-node-id model - st: make-structure compose [id: (nid) type: (type) x: (palette-pos-x) y: (palette-pos-y)] - if type = 'case-structure [append st/frames make-frame [id: 0 label: "0"]] - append model/structures st - palette-canvas/draw: render-bd model - show palette-canvas - unview -] - -open-palette: func [face x y /struct target-struct] [ - palette-canvas: face - palette-pos-x: x - palette-pos-y: y - palette-struct: target-struct - view/no-wait [ - title "Añadir bloque" - text "Aritmética:" return - button 80 "Add +" [palette-add-node 'add] - button 80 "Sub -" [palette-add-node 'sub] - button 80 "Mul *" [palette-add-node 'mul] - button 80 "Div /" [palette-add-node 'div] return - text "Constante / salida:" return - button 80 "Const" [palette-add-node 'const] - button 80 "Display" [palette-add-node 'display] return - text "Lógica:" return - button 80 "AND" [palette-add-node 'and-op] - button 80 "OR" [palette-add-node 'or-op] - button 80 "NOT" [palette-add-node 'not-op] - button 80 "B-Const" [palette-add-node 'bool-const] return - text "Comparadores:" return - button 80 ">" [palette-add-node 'gt-op] - button 80 "<" [palette-add-node 'lt-op] - button 80 "=" [palette-add-node 'eq-op] - button 80 "!=" [palette-add-node 'neq-op] return - text "String:" return - button 80 "S-Const" [palette-add-node 'str-const] - button 80 "Concat" [palette-add-node 'concat] - button 80 "Len" [palette-add-node 'str-length] - button 80 "→STR" [palette-add-node 'to-string] return - text "Array:" return - button 80 "Arr[]" [palette-add-node 'arr-const] - button 80 "Build[]" [palette-add-node 'build-array] - button 80 "Index[]" [palette-add-node 'index-array] return - button 80 "Size[]" [palette-add-node 'array-size] - button 80 "Subset[]" [palette-add-node 'array-subset] return - text "Cluster:" return - button 80 "Bundle" [palette-add-node 'bundle] - button 80 "Unbundle" [palette-add-node 'unbundle] return - text "Estructuras:" return - button 80 "While" [palette-add-structure 'while-loop] - button 80 "For" [palette-add-structure 'for-loop] - button 80 "Case" [palette-add-structure 'case-structure] return - button 80 "Add SR" [ - if palette-struct [ - unview - open-add-sr-dialog palette-canvas palette-struct - ] - ] - return - button "Cancelar" [unview] - ] -] - -; ── Shift Register helpers ────────────────────────────────────────── - -; Añade un SR de tipo dado a la estructura, calculando el y-offset automáticamente. -add-sr-to-structure: func [st dtype /local y sr] [ - y: 40 + (50 * length? st/shift-regs) - sr: make-shift-register compose [data-type: (dtype) y-offset: (y)] - append st/shift-regs sr -] - -; Vars de módulo para diálogos SR (patrón view/no-wait) -add-sr-canvas: none -add-sr-struct: none -sr-edit-canvas: none -sr-edit-sr-obj: none - -; Abre diálogo para elegir el tipo del nuevo shift register. -open-add-sr-dialog: func [canvas st] [ - add-sr-canvas: canvas - add-sr-struct: st - view/no-wait [ - title "Añadir shift register" - text "Tipo de dato:" return - button 80 "Number" [add-sr-to-structure add-sr-struct 'number - add-sr-canvas/draw: render-bd add-sr-canvas/extra - show add-sr-canvas unview] - button 80 "Boolean" [add-sr-to-structure add-sr-struct 'boolean - add-sr-canvas/draw: render-bd add-sr-canvas/extra - show add-sr-canvas unview] - button 80 "String" [add-sr-to-structure add-sr-struct 'string - add-sr-canvas/draw: render-bd add-sr-canvas/extra - show add-sr-canvas unview] return - button "Cancelar" [unview] - ] -] - -; Actualiza el init-value de un SR desde texto. -apply-sr-init-value: func [sr new-text /local val] [ - val: switch sr/data-type [ - string [new-text] - boolean [any [attempt [to-logic new-text] false]] - ] - if none? val [val: any [attempt [to-float new-text] 0.0]] - sr/init-value: val -] - -; Abre diálogo para editar el valor inicial de un SR. -open-sr-edit-dialog: func [canvas sr /local cur] [ - sr-edit-canvas: canvas - sr-edit-sr-obj: sr - cur: form sr/init-value - view/no-wait compose [ - title "Valor inicial SR" - text (rejoin [sr/name " [" form sr/data-type "]"]) return - text "Valor inicial:" return - sr-edit-fld: field 150 (cur) - on-enter [ - apply-sr-init-value sr-edit-sr-obj sr-edit-fld/text - sr-edit-canvas/draw: render-bd sr-edit-canvas/extra - unview - ] - return - button "OK" [ - apply-sr-init-value sr-edit-sr-obj sr-edit-fld/text - sr-edit-canvas/draw: render-bd sr-edit-canvas/extra - unview - ] - button "Cancelar" [unview] - ] -] +#include %canvas-dialogs.red -; Borra el elemento seleccionado (nodo, wire o estructura completa). -; Llamar desde el on-key del window padre con: canvas-delete-selected canvas canvas-delete-selected: func [canvas /local model node-id node-name node-type st found _pref _sst _ssr _frame] [ model: canvas/extra From 816eb02e265fbef61f21ba011b4d567cca621f6b Mon Sep 17 00:00:00 2001 From: OpenCodeMCP-BetaTest Date: Wed, 8 Apr 2026 13:40:49 +0200 Subject: [PATCH 05/14] =?UTF-8?q?refactor(4E):=20split=20conservador=20pan?= =?UTF-8?q?el.red=20=E2=80=94=20render=20y=20n=C3=BAcleo?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit panel.red (933 líneas) dividido en 2 ficheros: - panel-render.red (411): constantes visuales, helpers de tipo, render Draw puro (fp-color?, fp-border-color?, render-fp-grid, render-fp-item, render-fp-panel, etc.) - panel.red (535): hit-test, diálogos FP, paleta FP, actor render-panel, demo Order de includes: panel.red → panel-render.red Tests: 465/465 PASS Co-Authored-By: Claude Sonnet 4.6 --- src/ui/panel/panel-render.red | 411 ++++++++++++++++++++++++++++++++++ src/ui/panel/panel.red | 400 +-------------------------------- 2 files changed, 412 insertions(+), 399 deletions(-) create mode 100644 src/ui/panel/panel-render.red diff --git a/src/ui/panel/panel-render.red b/src/ui/panel/panel-render.red new file mode 100644 index 0000000..79a74c1 --- /dev/null +++ b/src/ui/panel/panel-render.red @@ -0,0 +1,411 @@ +Red [ + Title: "QTorres — panel-render" + Purpose: "Render puro del Front Panel: constantes visuales, helpers de tipo y Draw." + Needs: 'View +] + +; ── panel-render.red ────────────────────────────────────────────── +; Render puro del Front Panel. Incluido desde panel.red. +; No contiene estado mutable ni side-effects de UI. +; ────────────────────────────────────────────────────────────────── + +; ══════════════════════════════════════════════════════════ +; CONSTANTS — visual configuration +; ══════════════════════════════════════════════════════════ +fp-canvas-color: 225.228.235 +fp-control-color: 50.100.180 +fp-indicator-color: 175.125.20 +fp-text-color: 240.245.250 +fp-selected-color: 0.175.210 +fp-border-color: 30.60.120 +fp-item-width: 120 +fp-item-height: 40 +fp-label-height: 20 +fp-label-above: 18 +fp-run-button-height: 30 + +; Waveform dimensions (área de trazado) +fp-chart-width: 200 +fp-chart-height: 160 + +; GTK-010: en Linux/GTK, Draw text usa baseline como Y en vez de top-left. +; Compensamos añadiendo fp-text-dy a todas las coordenadas Y de texto. +fp-text-dy: either system/platform = 'Linux [8] [0] + +fp-color?: func [item-type] [ + either find [control bool-control str-control arr-control cluster-control] item-type [fp-control-color] [fp-indicator-color] +] + +fp-border-color?: func [item-type] [ + either find [control bool-control str-control arr-control cluster-control] item-type [fp-control-color - 20.20.20] [fp-indicator-color - 20.20.20] +] + +; fp-cluster-fields → model.red (4A) + +fp-cluster-height: func [item /local n] [ + n: (length? fp-cluster-fields item) / 2 + 20 + (max 1 n) * 20 +] + +fp-type-label?: func [item-type] [ + case [ + item-type = 'control ["DBL"] + item-type = 'indicator ["DBL"] + item-type = 'bool-control ["TF"] + item-type = 'bool-indicator ["TF"] + item-type = 'str-control ["STR"] + item-type = 'str-indicator ["STR"] + item-type = 'arr-control ["ARR"] + item-type = 'arr-indicator ["ARR"] + item-type = 'cluster-control ["CLU"] + item-type = 'cluster-indicator ["CLU"] + item-type = 'waveform-chart ["CHART"] + item-type = 'waveform-graph ["GRAPH"] + true [uppercase form item-type] + ] +] + +; ══════════════════════════════════════════════════════════ +; FP-ITEM — Constructor following DT-022/023 pattern +; ══════════════════════════════════════════════════════════ +; fp-default-label → model.red (4A) + +; make-fp-item → model.red (4A) + +fp-value-text: func [item] [ + either block? item/value [ + rejoin ["[" form item/value "]"] + ][ + form item/value + ] +] + +; ══════════════════════════════════════════════════════════ +; RENDER DRAW — pure functions, receive model, return Draw block +; ══════════════════════════════════════════════════════════ +render-fp-grid: func [w h /local cmds gx gy] [ + cmds: compose [pen 200.203.212 fill-pen 200.203.212 line-width 1] + gx: 20 + while [gx < w] [ + gy: 20 + while [gy < h] [ + append cmds compose [circle (as-pair gx gy) 1] + gy: gy + 20 + ] + gx: gx + 20 + ] + cmds +] + +; Genera segmentos de línea discontinua a lo largo de un rectángulo +dashed-box: func [x1 y1 x2 y2 dash gap /local cmds pos lim step] [ + cmds: copy [] + pos: x1 lim: x2 + while [pos < lim] [ + step: min dash (lim - pos) + append cmds compose [line (as-pair pos y1) (as-pair (pos + step) y1)] + pos: pos + dash + gap + ] + pos: y1 lim: y2 + while [pos < lim] [ + step: min dash (lim - pos) + append cmds compose [line (as-pair x2 pos) (as-pair x2 (pos + step))] + pos: pos + dash + gap + ] + pos: x2 lim: x1 + while [pos > lim] [ + step: min dash (pos - lim) + append cmds compose [line (as-pair pos y2) (as-pair (pos - step) y2)] + pos: pos - dash - gap + ] + pos: y2 lim: y1 + while [pos > lim] [ + step: min dash (pos - lim) + append cmds compose [line (as-pair x1 pos) (as-pair x1 (pos - step))] + pos: pos - dash - gap + ] + cmds +] + +; ══════════════════════════════════════════════════════════ +; RENDER WAVEFORM — Draw signal plot +; ══════════════════════════════════════════════════════════ + +render-waveform: func [item selected? /local cmds w h values min-y max-y y-range x-scale y-scale pts i v px py] [ + ; Dimensiones del área de trazado + w: fp-chart-width + h: fp-chart-height + cmds: copy [] + + ; Fondo negro (plot area estilo osciloscopio) + append cmds compose [ + pen 60.60.60 line-width 1 fill-pen 15.15.15 + box (as-pair item/offset/x item/offset/y) + (as-pair (item/offset/x + w) (item/offset/y + h)) 3 + ] + + ; Grid opcional: líneas grises cada 20% del área + append cmds [pen 40.40.40 line-width 1] + ; Líneas verticales + repeat i 4 [ + px: item/offset/x + (w * i / 5) + append cmds compose [line (as-pair px item/offset/y) (as-pair px (item/offset/y + h))] + ] + ; Líneas horizontales + repeat i 4 [ + py: item/offset/y + (h * i / 5) + append cmds compose [line (as-pair item/offset/x py) (as-pair (item/offset/x + w) py)] + ] + + ; Línea de señal (verde estilo osciloscopio) + values: any [item/value copy []] + ; Debug: verificar que values es un block + unless block? values [values: copy []] + ; Filtrar solo valores numéricos + values: copy values + remove-each v values [not number? v] + + if not empty? values [ + ; Calcular escala automática + ; Compute min and max manually (Red 0.6.6 lacks min-of/max-of) + min-y: first values + foreach v values [if v < min-y [min-y: v]] + max-y: first values + foreach v values [if v > max-y [max-y: v]] + + ; Evitar división por cero y dar margen + y-range: max-y - min-y + if y-range = 0 [y-range: 1] + ; Margen 10% arriba y abajo + min-y: min-y - (y-range * 0.1) + max-y: max-y + (y-range * 0.1) + y-range: max-y - min-y + + ; Escalar valores al área (dejando 10px margen) + y-scale: (h - 20) / y-range + x-scale: either (length? values) > 1 [ + (w - 20) / ((length? values) - 1) + ][ + w - 20 ; un solo punto: centrar + ] + + ; Generar puntos de la línea + pts: copy [] + i: 0 + foreach v values [ + px: item/offset/x + 10 + to-integer (i * x-scale) + py: item/offset/y + h - 10 - to-integer ((v - min-y) * y-scale) + append pts as-pair px py + i: i + 1 + ] + + ; Dibujar línea verde (line necesita >= 2 puntos en Draw) + either (length? pts) >= 2 [ + append cmds [pen 0.200.0 line-width 1] + line-cmd: copy [line] + append line-cmd pts + append cmds line-cmd + ][ + ; Un solo punto: dibujar círculo pequeño + append cmds compose [pen 0.200.0 fill-pen 0.200.0 circle (first pts) 2] + ] + ] + + ; Label del tipo (esquina superior izquierda) + type-lbl: fp-type-label? item/type + append cmds compose [ + pen 150.150.150 + text (as-pair (item/offset/x + 4) (item/offset/y + 4 + fp-text-dy)) (type-lbl) + ] + + ; Número de puntos (esquina superior derecha) + append cmds compose [ + pen 150.150.150 + text (as-pair (item/offset/x + w - 40) (item/offset/y + 4 + fp-text-dy)) + (rejoin ["n=" length? any [item/value copy []]]) + ] + + ; Selección: marco rallado + if selected? [ + append cmds compose [ + pen (fp-selected-color) + line-width 2 + fill-pen off + ] + append cmds dashed-box + (item/offset/x - 3) (item/offset/y - 3) + (item/offset/x + w + 3) (item/offset/y + h + 3) + 6 4 + append cmds [line-width 1] + ] + + cmds +] + +render-fp-item: func [item selected? /local cmds col border-col type-lbl led-col cx cy field-y field-h lx ly lw bh fy fn ft fval fval-str] [ + cmds: copy [] + ; Reset estado Draw — pen 0.0.0 es crítico: evita bleed de color de texto + append cmds [pen 0.0.0 fill-pen off line-width 1] + + ; ── Label encima del body (todos los tipos) ─────────────────────────────────────────── + if all [item/label object? item/label item/label/visible] [ + lx: item/offset/x + ly: item/offset/y - fp-label-above + if pair? item/label/offset [ + lx: lx + item/label/offset/x + ly: ly + item/label/offset/y + ] + append cmds compose [ + text (as-pair lx (ly + fp-text-dy)) (any [item/label/text ""]) + ] + ] + + ; ── Body ───────────────────────────────────────────────────────────────────────────── + case [ + item/data-type = 'string [ + ; String: campo blanco a partir de item/offset + either item/type = 'str-control [ + append cmds compose [ + pen 80.80.80 line-width 1 fill-pen 255.255.255 + box (as-pair item/offset/x item/offset/y) + (as-pair (item/offset/x + fp-item-width) (item/offset/y + fp-label-height)) 2 + ] + ][ + append cmds compose [ + pen 80.80.80 line-width 2 fill-pen 245.245.245 + box (as-pair item/offset/x item/offset/y) + (as-pair (item/offset/x + fp-item-width) (item/offset/y + fp-label-height)) 2 + ] + ] + append cmds compose [ + pen 20.20.20 fill-pen off + text (as-pair (item/offset/x + 4) (item/offset/y + 4 + fp-text-dy)) (fp-value-text item) + ] + ] + item/data-type = 'cluster [ + ; Cluster: caja marrón con campos internos + border-col: 100.50.10 + col: either item/type = 'cluster-control [159.89.39] [139.69.19] + bh: fp-cluster-height item + append cmds compose [ + pen (border-col) line-width 2 fill-pen (col) + box (as-pair item/offset/x item/offset/y) + (as-pair (item/offset/x + fp-item-width) (item/offset/y + bh)) 3 + pen 220.190.160 fill-pen off + text (as-pair (item/offset/x + 4) (item/offset/y + 4 + fp-text-dy)) "CLU" + ] + fy: item/offset/y + 20 + foreach [fn ft] fp-cluster-fields item [ + fval: select any [item/value copy []] fn + fval-str: either none? fval [""] [form fval] + append cmds compose [ + pen 240.220.200 fill-pen off + text (as-pair (item/offset/x + 4) (fy + fp-text-dy)) (rejoin [form fn ": " fval-str]) + ] + fy: fy + 20 + ] + ] + item/data-type = 'array [ + ; Array: caja de color con borde doble + valor como texto + col: fp-color? item/type + border-col: fp-border-color? item/type + ; Borde exterior + append cmds compose [ + pen (border-col) line-width 3 fill-pen (col) + box (as-pair item/offset/x item/offset/y) + (as-pair (item/offset/x + fp-item-width) (item/offset/y + fp-item-height)) 4 + ] + ; Borde interior (doble) + append cmds compose [ + pen (col + 20.20.20) line-width 1 fill-pen off + box (as-pair (item/offset/x + 4) (item/offset/y + 4)) + (as-pair (item/offset/x + fp-item-width - 4) (item/offset/y + fp-item-height - 4)) 3 + ] + append cmds compose [ + pen 220.230.240 fill-pen off + text (as-pair (item/offset/x + 4) (item/offset/y + 5 + fp-text-dy)) "ARR" + ] + append cmds compose [ + pen 255.255.255 fill-pen off + text (as-pair (item/offset/x + 4) (item/offset/y + fp-item-height - 14 + fp-text-dy)) + (fp-value-text item) + ] + ] + item/data-type = 'waveform [ + ; Waveform: renderiza gráfico estilo osciloscopio + append cmds render-waveform item selected? + ] + true [ + ; Numeric / Boolean: caja de color + col: fp-color? item/type + border-col: fp-border-color? item/type + append cmds compose [ + pen (border-col) line-width 1 fill-pen (col) + box (as-pair item/offset/x item/offset/y) + (as-pair (item/offset/x + fp-item-width) (item/offset/y + fp-item-height)) 4 + ] + type-lbl: fp-type-label? item/type + append cmds compose [ + pen 220.230.240 fill-pen off + text (as-pair (item/offset/x + 4) (item/offset/y + 5 + fp-text-dy)) (type-lbl) + ] + either item/data-type = 'boolean [ + led-col: either item/value [0.180.0] [180.0.0] + cx: item/offset/x + fp-item-width - 20 + cy: item/offset/y + (fp-item-height / 2) + append cmds compose [ + pen (led-col - 40.40.40) line-width 1 fill-pen (led-col) + circle (as-pair cx cy) 10 + ] + ][ + append cmds compose [ + pen 255.255.255 fill-pen off + text (as-pair (item/offset/x + 4) (item/offset/y + fp-item-height - 14 + fp-text-dy)) + (fp-value-text item) + ] + ] + ] + ] ; end case + + ; ── Selección: marcos rallados en body y label ──────────────────────────────────────── + bh: case [ + item/data-type = 'string [fp-label-height] + item/data-type = 'cluster [fp-cluster-height item] + item/data-type = 'waveform [fp-chart-height] + true [fp-item-height] + ] + if selected? [ + append cmds compose [pen (fp-selected-color) line-width 2 fill-pen off] + append cmds dashed-box + (item/offset/x - 3) (item/offset/y - 3) + (item/offset/x + fp-item-width + 3) (item/offset/y + bh + 3) + 6 4 + if all [item/label object? item/label item/label/visible] [ + lx: item/offset/x + ly: item/offset/y - fp-label-above + if pair? item/label/offset [ + lx: lx + item/label/offset/x + ly: ly + item/label/offset/y + ] + lw: max 30 (7 * length? any [item/label/text ""]) + append cmds compose [pen (fp-selected-color) line-width 1 fill-pen off] + append cmds dashed-box (lx - 2) (ly - 2) (lx + lw + 2) (ly + 15) 4 3 + ] + append cmds [line-width 1] + ] + cmds +] + +render-fp-panel: func [model w h /local cmds item selected?] [ + cmds: copy [] + + append cmds render-fp-grid w h + + foreach item model/front-panel [ + selected?: either model/selected-fp [same? item model/selected-fp] [false] + append cmds render-fp-item item selected? + ] + + cmds +] + diff --git a/src/ui/panel/panel.red b/src/ui/panel/panel.red index db18518..5fb5d2d 100644 --- a/src/ui/panel/panel.red +++ b/src/ui/panel/panel.red @@ -4,405 +4,7 @@ Red [ Needs: 'View ] -; ══════════════════════════════════════════════════════════ -; CONSTANTS — visual configuration -; ══════════════════════════════════════════════════════════ -fp-canvas-color: 225.228.235 -fp-control-color: 50.100.180 -fp-indicator-color: 175.125.20 -fp-text-color: 240.245.250 -fp-selected-color: 0.175.210 -fp-border-color: 30.60.120 -fp-item-width: 120 -fp-item-height: 40 -fp-label-height: 20 -fp-label-above: 18 -fp-run-button-height: 30 - -; Waveform dimensions (área de trazado) -fp-chart-width: 200 -fp-chart-height: 160 - -; GTK-010: en Linux/GTK, Draw text usa baseline como Y en vez de top-left. -; Compensamos añadiendo fp-text-dy a todas las coordenadas Y de texto. -fp-text-dy: either system/platform = 'Linux [8] [0] - -fp-color?: func [item-type] [ - either find [control bool-control str-control arr-control cluster-control] item-type [fp-control-color] [fp-indicator-color] -] - -fp-border-color?: func [item-type] [ - either find [control bool-control str-control arr-control cluster-control] item-type [fp-control-color - 20.20.20] [fp-indicator-color - 20.20.20] -] - -; fp-cluster-fields → model.red (4A) - -fp-cluster-height: func [item /local n] [ - n: (length? fp-cluster-fields item) / 2 - 20 + (max 1 n) * 20 -] - -fp-type-label?: func [item-type] [ - case [ - item-type = 'control ["DBL"] - item-type = 'indicator ["DBL"] - item-type = 'bool-control ["TF"] - item-type = 'bool-indicator ["TF"] - item-type = 'str-control ["STR"] - item-type = 'str-indicator ["STR"] - item-type = 'arr-control ["ARR"] - item-type = 'arr-indicator ["ARR"] - item-type = 'cluster-control ["CLU"] - item-type = 'cluster-indicator ["CLU"] - item-type = 'waveform-chart ["CHART"] - item-type = 'waveform-graph ["GRAPH"] - true [uppercase form item-type] - ] -] - -; ══════════════════════════════════════════════════════════ -; FP-ITEM — Constructor following DT-022/023 pattern -; ══════════════════════════════════════════════════════════ -; fp-default-label → model.red (4A) - -; make-fp-item → model.red (4A) - -fp-value-text: func [item] [ - either block? item/value [ - rejoin ["[" form item/value "]"] - ][ - form item/value - ] -] - -; ══════════════════════════════════════════════════════════ -; RENDER DRAW — pure functions, receive model, return Draw block -; ══════════════════════════════════════════════════════════ -render-fp-grid: func [w h /local cmds gx gy] [ - cmds: compose [pen 200.203.212 fill-pen 200.203.212 line-width 1] - gx: 20 - while [gx < w] [ - gy: 20 - while [gy < h] [ - append cmds compose [circle (as-pair gx gy) 1] - gy: gy + 20 - ] - gx: gx + 20 - ] - cmds -] - -; Genera segmentos de línea discontinua a lo largo de un rectángulo -dashed-box: func [x1 y1 x2 y2 dash gap /local cmds pos lim step] [ - cmds: copy [] - pos: x1 lim: x2 - while [pos < lim] [ - step: min dash (lim - pos) - append cmds compose [line (as-pair pos y1) (as-pair (pos + step) y1)] - pos: pos + dash + gap - ] - pos: y1 lim: y2 - while [pos < lim] [ - step: min dash (lim - pos) - append cmds compose [line (as-pair x2 pos) (as-pair x2 (pos + step))] - pos: pos + dash + gap - ] - pos: x2 lim: x1 - while [pos > lim] [ - step: min dash (pos - lim) - append cmds compose [line (as-pair pos y2) (as-pair (pos - step) y2)] - pos: pos - dash - gap - ] - pos: y2 lim: y1 - while [pos > lim] [ - step: min dash (pos - lim) - append cmds compose [line (as-pair x1 pos) (as-pair x1 (pos - step))] - pos: pos - dash - gap - ] - cmds -] - -; ══════════════════════════════════════════════════════════ -; RENDER WAVEFORM — Draw signal plot -; ══════════════════════════════════════════════════════════ - -render-waveform: func [item selected? /local cmds w h values min-y max-y y-range x-scale y-scale pts i v px py] [ - ; Dimensiones del área de trazado - w: fp-chart-width - h: fp-chart-height - cmds: copy [] - - ; Fondo negro (plot area estilo osciloscopio) - append cmds compose [ - pen 60.60.60 line-width 1 fill-pen 15.15.15 - box (as-pair item/offset/x item/offset/y) - (as-pair (item/offset/x + w) (item/offset/y + h)) 3 - ] - - ; Grid opcional: líneas grises cada 20% del área - append cmds [pen 40.40.40 line-width 1] - ; Líneas verticales - repeat i 4 [ - px: item/offset/x + (w * i / 5) - append cmds compose [line (as-pair px item/offset/y) (as-pair px (item/offset/y + h))] - ] - ; Líneas horizontales - repeat i 4 [ - py: item/offset/y + (h * i / 5) - append cmds compose [line (as-pair item/offset/x py) (as-pair (item/offset/x + w) py)] - ] - - ; Línea de señal (verde estilo osciloscopio) - values: any [item/value copy []] - ; Debug: verificar que values es un block - unless block? values [values: copy []] - ; Filtrar solo valores numéricos - values: copy values - remove-each v values [not number? v] - - if not empty? values [ - ; Calcular escala automática - ; Compute min and max manually (Red 0.6.6 lacks min-of/max-of) - min-y: first values - foreach v values [if v < min-y [min-y: v]] - max-y: first values - foreach v values [if v > max-y [max-y: v]] - - ; Evitar división por cero y dar margen - y-range: max-y - min-y - if y-range = 0 [y-range: 1] - ; Margen 10% arriba y abajo - min-y: min-y - (y-range * 0.1) - max-y: max-y + (y-range * 0.1) - y-range: max-y - min-y - - ; Escalar valores al área (dejando 10px margen) - y-scale: (h - 20) / y-range - x-scale: either (length? values) > 1 [ - (w - 20) / ((length? values) - 1) - ][ - w - 20 ; un solo punto: centrar - ] - - ; Generar puntos de la línea - pts: copy [] - i: 0 - foreach v values [ - px: item/offset/x + 10 + to-integer (i * x-scale) - py: item/offset/y + h - 10 - to-integer ((v - min-y) * y-scale) - append pts as-pair px py - i: i + 1 - ] - - ; Dibujar línea verde (line necesita >= 2 puntos en Draw) - either (length? pts) >= 2 [ - append cmds [pen 0.200.0 line-width 1] - line-cmd: copy [line] - append line-cmd pts - append cmds line-cmd - ][ - ; Un solo punto: dibujar círculo pequeño - append cmds compose [pen 0.200.0 fill-pen 0.200.0 circle (first pts) 2] - ] - ] - - ; Label del tipo (esquina superior izquierda) - type-lbl: fp-type-label? item/type - append cmds compose [ - pen 150.150.150 - text (as-pair (item/offset/x + 4) (item/offset/y + 4 + fp-text-dy)) (type-lbl) - ] - - ; Número de puntos (esquina superior derecha) - append cmds compose [ - pen 150.150.150 - text (as-pair (item/offset/x + w - 40) (item/offset/y + 4 + fp-text-dy)) - (rejoin ["n=" length? any [item/value copy []]]) - ] - - ; Selección: marco rallado - if selected? [ - append cmds compose [ - pen (fp-selected-color) - line-width 2 - fill-pen off - ] - append cmds dashed-box - (item/offset/x - 3) (item/offset/y - 3) - (item/offset/x + w + 3) (item/offset/y + h + 3) - 6 4 - append cmds [line-width 1] - ] - - cmds -] - -render-fp-item: func [item selected? /local cmds col border-col type-lbl led-col cx cy field-y field-h lx ly lw bh fy fn ft fval fval-str] [ - cmds: copy [] - ; Reset estado Draw — pen 0.0.0 es crítico: evita bleed de color de texto - append cmds [pen 0.0.0 fill-pen off line-width 1] - - ; ── Label encima del body (todos los tipos) ─────────────────────────────────────────── - if all [item/label object? item/label item/label/visible] [ - lx: item/offset/x - ly: item/offset/y - fp-label-above - if pair? item/label/offset [ - lx: lx + item/label/offset/x - ly: ly + item/label/offset/y - ] - append cmds compose [ - text (as-pair lx (ly + fp-text-dy)) (any [item/label/text ""]) - ] - ] - - ; ── Body ───────────────────────────────────────────────────────────────────────────── - case [ - item/data-type = 'string [ - ; String: campo blanco a partir de item/offset - either item/type = 'str-control [ - append cmds compose [ - pen 80.80.80 line-width 1 fill-pen 255.255.255 - box (as-pair item/offset/x item/offset/y) - (as-pair (item/offset/x + fp-item-width) (item/offset/y + fp-label-height)) 2 - ] - ][ - append cmds compose [ - pen 80.80.80 line-width 2 fill-pen 245.245.245 - box (as-pair item/offset/x item/offset/y) - (as-pair (item/offset/x + fp-item-width) (item/offset/y + fp-label-height)) 2 - ] - ] - append cmds compose [ - pen 20.20.20 fill-pen off - text (as-pair (item/offset/x + 4) (item/offset/y + 4 + fp-text-dy)) (fp-value-text item) - ] - ] - item/data-type = 'cluster [ - ; Cluster: caja marrón con campos internos - border-col: 100.50.10 - col: either item/type = 'cluster-control [159.89.39] [139.69.19] - bh: fp-cluster-height item - append cmds compose [ - pen (border-col) line-width 2 fill-pen (col) - box (as-pair item/offset/x item/offset/y) - (as-pair (item/offset/x + fp-item-width) (item/offset/y + bh)) 3 - pen 220.190.160 fill-pen off - text (as-pair (item/offset/x + 4) (item/offset/y + 4 + fp-text-dy)) "CLU" - ] - fy: item/offset/y + 20 - foreach [fn ft] fp-cluster-fields item [ - fval: select any [item/value copy []] fn - fval-str: either none? fval [""] [form fval] - append cmds compose [ - pen 240.220.200 fill-pen off - text (as-pair (item/offset/x + 4) (fy + fp-text-dy)) (rejoin [form fn ": " fval-str]) - ] - fy: fy + 20 - ] - ] - item/data-type = 'array [ - ; Array: caja de color con borde doble + valor como texto - col: fp-color? item/type - border-col: fp-border-color? item/type - ; Borde exterior - append cmds compose [ - pen (border-col) line-width 3 fill-pen (col) - box (as-pair item/offset/x item/offset/y) - (as-pair (item/offset/x + fp-item-width) (item/offset/y + fp-item-height)) 4 - ] - ; Borde interior (doble) - append cmds compose [ - pen (col + 20.20.20) line-width 1 fill-pen off - box (as-pair (item/offset/x + 4) (item/offset/y + 4)) - (as-pair (item/offset/x + fp-item-width - 4) (item/offset/y + fp-item-height - 4)) 3 - ] - append cmds compose [ - pen 220.230.240 fill-pen off - text (as-pair (item/offset/x + 4) (item/offset/y + 5 + fp-text-dy)) "ARR" - ] - append cmds compose [ - pen 255.255.255 fill-pen off - text (as-pair (item/offset/x + 4) (item/offset/y + fp-item-height - 14 + fp-text-dy)) - (fp-value-text item) - ] - ] - item/data-type = 'waveform [ - ; Waveform: renderiza gráfico estilo osciloscopio - append cmds render-waveform item selected? - ] - true [ - ; Numeric / Boolean: caja de color - col: fp-color? item/type - border-col: fp-border-color? item/type - append cmds compose [ - pen (border-col) line-width 1 fill-pen (col) - box (as-pair item/offset/x item/offset/y) - (as-pair (item/offset/x + fp-item-width) (item/offset/y + fp-item-height)) 4 - ] - type-lbl: fp-type-label? item/type - append cmds compose [ - pen 220.230.240 fill-pen off - text (as-pair (item/offset/x + 4) (item/offset/y + 5 + fp-text-dy)) (type-lbl) - ] - either item/data-type = 'boolean [ - led-col: either item/value [0.180.0] [180.0.0] - cx: item/offset/x + fp-item-width - 20 - cy: item/offset/y + (fp-item-height / 2) - append cmds compose [ - pen (led-col - 40.40.40) line-width 1 fill-pen (led-col) - circle (as-pair cx cy) 10 - ] - ][ - append cmds compose [ - pen 255.255.255 fill-pen off - text (as-pair (item/offset/x + 4) (item/offset/y + fp-item-height - 14 + fp-text-dy)) - (fp-value-text item) - ] - ] - ] - ] ; end case - - ; ── Selección: marcos rallados en body y label ──────────────────────────────────────── - bh: case [ - item/data-type = 'string [fp-label-height] - item/data-type = 'cluster [fp-cluster-height item] - item/data-type = 'waveform [fp-chart-height] - true [fp-item-height] - ] - if selected? [ - append cmds compose [pen (fp-selected-color) line-width 2 fill-pen off] - append cmds dashed-box - (item/offset/x - 3) (item/offset/y - 3) - (item/offset/x + fp-item-width + 3) (item/offset/y + bh + 3) - 6 4 - if all [item/label object? item/label item/label/visible] [ - lx: item/offset/x - ly: item/offset/y - fp-label-above - if pair? item/label/offset [ - lx: lx + item/label/offset/x - ly: ly + item/label/offset/y - ] - lw: max 30 (7 * length? any [item/label/text ""]) - append cmds compose [pen (fp-selected-color) line-width 1 fill-pen off] - append cmds dashed-box (lx - 2) (ly - 2) (lx + lw + 2) (ly + 15) 4 3 - ] - append cmds [line-width 1] - ] - cmds -] - -render-fp-panel: func [model w h /local cmds item selected?] [ - cmds: copy [] - - append cmds render-fp-grid w h - - foreach item model/front-panel [ - selected?: either model/selected-fp [same? item model/selected-fp] [false] - append cmds render-fp-item item selected? - ] - - cmds -] +#include %panel-render.red ; ══════════════════════════════════════════════════════════ ; HIT TESTING — pure functions From 8d4a604e02fdc7e2f4ae70d63a66ace442c45cc1 Mon Sep 17 00:00:00 2001 From: OpenCodeMCP-BetaTest Date: Wed, 8 Apr 2026 13:42:23 +0200 Subject: [PATCH 06/14] docs: actualizar CLAUDE.md con estructura real post-refactor 4A-4E MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Estructura de ficheros: canvas-render.red, canvas-dialogs.red, panel-render.red - Tamaños actuales: canvas.red 1226, panel.red 535, compiler.red 1029, model.red 635 - Estado Fase 2: COMPLETADA (pendiente merge PR #60) - Problemas de arquitectura: actualizada tabla de responsabilidades (4A ✅) - task_plan.md: fases 4D y 4E marcadas como completadas - progress.md: log de sesión actualizado Co-Authored-By: Claude Sonnet 4.6 --- CLAUDE.md | 97 ++++++++++++----------- progress.md | 39 ++++++++- task_plan.md | 218 ++++++++++++++++++++++++++++----------------------- 3 files changed, 210 insertions(+), 144 deletions(-) diff --git a/CLAUDE.md b/CLAUDE.md index 328502e..fb9837b 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -57,21 +57,24 @@ QTorres/ │ ├── labview-comportamiento.md # Arquitectura LabVIEW: renderizado, modos, estilos │ └── GTK_ISSUES.md # Bugs del backend GTK en Linux ├── src/ -│ ├── qtorres.red # Punto de entrada + toolbar + ventana principal (226 líneas) +│ ├── qtorres.red # Punto de entrada + toolbar + ventana principal │ ├── graph/ -│ │ ├── model.red # Modelo: make-label, base-element, make-node, make-wire, make-frame, gen-name (346 líneas) -│ │ └── blocks.red # Registro de bloques + dialecto block-def — 34 bloques (324 líneas) +│ │ ├── model.red # Modelo: make-label, make-node, make-wire, make-fp-item, set-config, find-node-by-id (635 líneas) +│ │ └── blocks.red # Registro de bloques + dialecto block-def — 34 bloques │ ├── compiler/ -│ │ └── compiler.red # Compilador: topo-sort, bind-emit, compile-body/diagram/structures (831 líneas) +│ │ └── compiler.red # Compilador: topo-sort, bind-emit, compile-body/diagram/panel (1029 líneas) │ ├── runner/ -│ │ └── runner.red # Runner: ejecución en memoria con do (33 líneas) +│ │ └── runner.red # Runner: ejecución en memoria con do │ ├── io/ -│ │ └── file-io.red # File I/O: serialize, format, save/load .qvi (647 líneas) +│ │ └── file-io.red # File I/O: serialize, format, save/load .qvi, save/load-panel (738 líneas) │ └── ui/ │ ├── diagram/ -│ │ └── canvas.red # Block Diagram canvas: render, hit-test, eventos (2383 líneas) ⚠️ SPLIT PENDIENTE +│ │ ├── canvas.red # BD canvas: hit-test, CRUD, actor render-diagram (1226 líneas) +│ │ ├── canvas-render.red # Render puro BD: constantes, geometría, Draw (932 líneas) +│ │ └── canvas-dialogs.red # Diálogos edición, paleta, SR helpers (397 líneas) │ └── panel/ -│ └── panel.red # Front Panel: render, hit-test, compile-panel (928 líneas) +│ ├── panel.red # FP: hit-test, diálogos, paleta, actor render-panel (535 líneas) +│ └── panel-render.red # Render puro FP: constantes, Draw, waveform (411 líneas) ├── tests/ │ ├── run-all.red # Runner de tests automatizados │ ├── test-blocks.red # Tests del registro de bloques (34 bloques, puertos, emit) @@ -103,15 +106,21 @@ QTorres/ - Runner en memoria, File I/O con round-trip, Front Panel con Draw - Tests automatizados + CI en GitHub Actions -**Fase 2 — EN PROGRESO.** Tipos de datos y estructuras de control: +**Fase 2 ✅ COMPLETADA (pendiente merge PR#60).** Tipos de datos y estructuras de control: - ~~#9 Tipo booleano~~ ✅ - ~~#10 Tipo string~~ ✅ - ~~#14 While Loop~~ ✅ (con shift registers) - ~~#15 For Loop~~ ✅ - ~~#11 Array 1D~~ ✅ (bloques arr-const, build-array, index-array, array-size, array-subset) -- ~~#16 Case Structure~~ ✅ (PR#46 pendiente de merge — frames navegables, case/either) +- ~~#16 Case Structure~~ ✅ +- ~~#12 Cluster~~ ✅ +- ~~#13 Waveform Chart y Graph~~ ✅ +- ~~#54 Cluster persiste campos~~ ✅ ~~#48/#50/#51 bugs menores~~ ✅ +- QA-018/029: protecciones de integridad ✅ +- Refactor 4A-4E: responsabilidades reorganizadas, ficheros grandes divididos ✅ +- 465 tests PASS -**Próximo paso:** Issue #12 (Cluster). +**Próximo paso:** Fase 3 — #17 Sub-VI con connector pane. ## Decisiones técnicas clave @@ -373,50 +382,50 @@ Cubre sintaxis core, View, Draw, VID, Parse, patrones idiomáticos y gotchas. ### Responsabilidades mal ubicadas -| Función | Está en | Debería estar en | Por qué | -|---------|---------|-------------------|---------| -| `compile-panel`, `gen-panel-var-name`, `gen-standalone-code` | panel.red | compiler.red | Lógica de compilación en un módulo de UI | -| `save-panel-to-diagram`, `load-panel-from-diagram` | panel.red | file-io.red | Serialización en un módulo de UI | -| `make-diagram-model` | canvas.red | model.red | Creación de modelo en un módulo de UI | -| `make-fp-item` | panel.red | model.red | Constructor de datos en un módulo de UI | -| Lógica de `btn-run` (50+ líneas inline) | qtorres.red | función nombrada (ej: `run-diagram`) | Lógica de negocio inline en un actor de face | +> **Refactor 4A completado (2026-04-08, PR #60):** Las responsabilidades más críticas ya están en sus módulos correctos. -### Dependencia circular canvas.red <-> panel.red +| Función | Movida a | Estado | +|---------|----------|--------| +| `compile-panel`, `gen-panel-var-name`, `gen-standalone-code` | `compiler.red` | ✅ Movida | +| `save-panel-to-diagram`, `load-panel-from-diagram` | `file-io.red` | ✅ Movida | +| `make-diagram-model` | `model.red` | ✅ Movida | +| `make-fp-item`, `fp-cluster-fields`, `fp-default-label` | `model.red` | ✅ Movida | +| `find-node-by-id` | `model.red` | ✅ Añadida | +| `set-config` | `model.red` | ✅ Añadida | +| Lógica de `btn-run` (50+ líneas inline) | qtorres.red | ⚠️ Pendiente Fase 3 | + +### Dependencia canvas.red <-> panel.red - `canvas.red` llama a `render-fp-panel` (definida en panel.red) -- `panel.red` llama a `render-bd`, `gen-node-id` (definidas en canvas.red) +- `panel.red` llama a `render-bd`, `gen-node-id` (definidas en canvas-render.red) -Funciona porque el chain loading carga canvas antes que panel, pero: -- Ninguno puede testearse aisladamente -- El orden de `#include` es frágil -- **Regla para IA:** NO agravar esta dependencia. Si necesitas sincronizar BD↔FP, usar el patrón existente; no crear nuevas dependencias cruzadas. +El acoplamiento es **por diseño del dominio** (FP↔BD son una unidad 1:1) y no es deuda técnica. +- **Regla para IA:** NO agravar esta dependencia. Usar el patrón existente para sincronizar BD↔FP. -### Ficheros demasiado grandes (riesgo de pérdida de contexto) +### Ficheros y tamaños (2026-04-08) -| Fichero | Líneas | Riesgo | -|---------|--------|--------| -| canvas.red | 2383 | **CRÍTICO** — split urgente. Render, hit-test, eventos, diálogos, paleta, CRUD, modelo, estructuras, arrays. | -| panel.red | 928 | **ALTO** — Render + hit-test + eventos + serialización + compilación + diálogos + demo. | -| compiler.red | 831 | **ALTO** — compile-diagram + todas las estructuras. | -| file-io.red | 647 | Medio — `format-qvi` recorre `ui-layout` por índice (frágil). | +| Fichero | Líneas | Contenido | +|---------|--------|-----------| +| canvas.red | 1226 | Hit-test, CRUD, actor render-diagram | +| canvas-render.red | 932 | Constantes visuales, geometría, Draw | +| canvas-dialogs.red | 397 | Diálogos de edición, paleta, SR helpers | +| panel.red | 535 | Hit-test, diálogos FP, paleta FP, actor | +| panel-render.red | 411 | Constantes FP, render Draw, waveform | +| compiler.red | 1029 | compile-diagram + compile-panel + estructuras | +| file-io.red | 738 | serialize, save/load .qvi, save/load panel | +| model.red | 635 | Constructores, helpers, find-node-by-id, set-config | -**Regla para IA:** Al trabajar en canvas.red o panel.red, leer el fichero COMPLETO antes de hacer cambios. No asumir que entiendes la estructura por haber leído solo una parte. +**Regla para IA:** Al trabajar en canvas.red o panel.red y sus submódulos, leer el fichero COMPLETO antes de hacer cambios. -### Abstracciones que faltan +### Abstracciones pendientes -1. **`find-node-by-id`** — El patrón `foreach node model/nodes [if node/id = target-id [...]]` se repite ~15 veces en canvas.red, compiler.red, panel.red y qtorres.red. Debería ser una función en model.red. -2. **`set-config`** — El patrón `either pos: find node/config 'default [pos/2: val] [append node/config reduce ['default val]]` se repite 3 veces en canvas.red. Debería ser un helper en model.red. -3. **Conocimiento de tipos disperso** — El comportamiento por tipo (`bool-const`, `str-const`, etc.) está hardcodeado en canvas.red, panel.red, compiler.red y blocks.red. Añadir un tipo nuevo requiere tocar 4+ ficheros en 10+ ubicaciones. blocks.red debería llevar hints de renderizado/compilación. +1. **Conocimiento de tipos disperso** — El comportamiento por tipo (`bool-const`, `str-const`, etc.) está hardcodeado en canvas-render.red, panel-render.red, compiler.red y blocks.red. Añadir un tipo nuevo requiere tocar 4+ ficheros. blocks.red debería llevar hints de renderizado/compilación. ### Estado global compartido -`app-model` (definido en qtorres.red) es el único modelo compartido. canvas.red, panel.red y qtorres.red lo leen y mutan a través de `face/extra`. No hay mecanismo de notificación — cada módulo muta directamente y llama al render del otro. +`app-model` (definido en qtorres.red) es el único modelo compartido. canvas.red, panel.red y qtorres.red lo leen y mutan a través de `face/extra`. No hay mecanismo de notificación. -### Plan de corrección (NO ejecutar ahora) +### Plan de corrección (pendiente Fase 3) -Estos refactorings se harán como Issues dedicados cuando haya un hueco entre features: -1. Extraer `make-diagram-model` y `make-fp-item` → model.red -2. Mover `compile-panel` + helpers → compiler.red -3. Mover `save/load-panel-*` → file-io.red -4. Añadir `find-node-by-id` y `set-config` a model.red -5. Romper la dependencia circular canvas↔panel con callbacks +1. Centralizar conocimiento de tipos en blocks.red (hints de renderizado) +2. Extraer lógica de `btn-run` a función nombrada en qtorres.red diff --git a/progress.md b/progress.md index 7ee2457..9bf2455 100644 --- a/progress.md +++ b/progress.md @@ -1,6 +1,22 @@ -# Progress — Issue #13: Waveform Chart y Graph +# Progress Log — Transición Fase 2 -## Session Log +## Session 2026-04-07 — Cierre de Fase 2 + +### Fase 0 — Sincronización ✅ + +**0.1-0.3** Sincronizado con origin/main (commit 8dc1610). Línea base: **450 tests PASS**. + +**0.4** Conteo de líneas actual: +- canvas.red: 2557 líneas +- panel.red: 1255 líneas +- compiler.red: 891 líneas +- file-io.red: 647 líneas + +**Próximo:** Delegar análisis bug #54 (Cluster) a qwen3-coder:480b. + +--- + +## Session Log — Issue #13 (histórico) ### 2026-04-03 — Implementación completa (infraestructura) @@ -74,4 +90,21 @@ ## Próximo paso -El issue #13 está completo en cuanto a infraestructura. La funcionalidad completa de Chart dentro de loops requiere implementar drag de nodos dentro/fuera de estructuras. \ No newline at end of file +El issue #13 está completo en cuanto a infraestructura. La funcionalidad completa de Chart dentro de loops requiere implementar drag de nodos dentro/fuera de estructuras. + +## Session 2026-04-08 — Bug #54 + QA fixes + +- Fase 1 del plan completada: bug #54 (cluster no persiste campos) + - canvas.red: cluster-control/cluster-indicator añadidos al dbl-click handler (L2357, L2399) + - model.red: cluster-in-ports ahora incluye 'cluster-indicator, cluster-out-ports incluye 'cluster-control + - model.red: añadido helper `wire-port-in-used?` para QA-018 + - canvas.red: QA-018 aplicado en 3 lugares (L1911, L1933, L2309) +- Fase 2 del plan completada: protecciones QA + - QA-018: `wire-port-in-used?` en model.red + 3 llamadas en canvas.red ✅ + - QA-024: `fp-default-label` ya tenía todos los tipos cubiertos ✅ (ya estaba) + - QA-029: `save-panel-to-diagram` ahora guarda item/value en lugar de item/default (panel.red L1017) ✅ +- Bonus refactor (hecho por opencode agent): + - load-panel-from-diagram movida de panel.red a file-io.red (Fase 4A parcial) + - apply-const/str/arr-value en canvas.red usan `set-config` (Fase 4B parcial) +- Tests: 450/450 PASS +- Modelos usados: kimi-k2.5 (análisis + canvas.red), qwen3-coder-next (panel.red) \ No newline at end of file diff --git a/task_plan.md b/task_plan.md index 2ffac28..1c035a8 100644 --- a/task_plan.md +++ b/task_plan.md @@ -1,140 +1,164 @@ -# Plan — Issue #13: Waveform Chart y Graph +# Plan — Transición limpia a Fase 3 -## Contexto +**Creado:** 2026-04-07 +**Objetivo:** Cerrar Fase 2 con calidad para abrir Fase 3 (#17 Sub-VIs) sin arrastrar deuda bloqueante. -**Issue:** #13 - Waveform chart y graph en Front Panel -**Prioridad:** 7 de 8 en Fase 2 (último feature de Fase 2) -**Estado:** ✅ COMPLETADO +## Fuentes -**Objetivo:** Implementar controles de visualización de señales en el Front Panel: -- **Waveform Chart:** acumula valores en cada iteración (buffer circular) -- **Waveform Graph:** muestra un array completo como señal +- `docs/auditoria-fase-2.md` (2026-04-03, qwen3-coder:480b) — veredicto 🟢 verde con refactor 🟡 bloqueante +- `CLAUDE.md` sección "Problemas conocidos de arquitectura" +- Issues abiertos: #28, #48, #49, #50, #51, #54 + QA-018/024/029 -**Referencias LabVIEW:** -- [NI Knowledge Base: Waveform Graphs vs Charts](https://knowledge.ni.com/KnowledgeArticleDetails?id=kA00Z000000P9zsSAC) -- [LabVIEW Docs: Waveform Charts](https://ni.com/docs/en-US/bundle/labview/page/waveform-charts.html) +## Reglas absolutas (recordatorio) -**Problema:** No hay validación que impida conectar dos wires al mismo puerto de entrada. Viola visual-spec 5.2. +- Todo en Red-Lang. Sin crear módulos nuevos sin aprobación. +- `./red-cli tests/run-all.red` debe pasar tras cada cambio (línea base: 450/450). +- NUNCA empezar una fase sin completar la anterior. +- NUNCA mergear PRs sin aprobación del usuario. +- Consultar `skills/red-lang/SKILL.md` antes de tocar Draw/View. -## Fases +## Estrategia de delegación a Ollama -### Phase 0: Diseño ✅ COMPLETE +Delegación habilitada a través de MCP configurado en el proyecto. El contexto (CLAUDE.md + skill Red-Lang) se carga automáticamente. -Diseño completado y aprobado. Ver detalles en `/home/alaforga/.claude/plans/toasty-plotting-parrot.md`. +| Tarea | Herramienta recomendada | Razón | +|-------|-------------------------|-------| +| Lectura masiva de canvas.red/panel.red | Task tool con agent explore | Contexto largo, análisis de codebase | +| Búsqueda de patrones específicos | Grep/Glob directos | Más rápido que delegar | +| Generación de tests Red | Decisión case-by-case | Según complejidad | +| Decisiones arquitectónicas | Claude (NO delegar) | Ollama no razona bien trade-offs | +| Escritura de ficheros | Claude (NO delegar) | Requiere revisión manual | -### Phase 1: Registro de bloques ✅ COMPLETE +## Hitos del plan -**Fichero:** `src/graph/blocks.red` +### Fase 0 — Sincronización ✅ COMPLETADA -**Cambios:** -- [x] 1.1 Añadir `waveform-chart` al block-registry -- [x] 1.2 Añadir `waveform-graph` al block-registry -- [x] 1.3 Añadir tests en `tests/test-blocks.red` +- [x] **0.1** Informar de divergencia local vs origin/main +- [x] **0.2** Reset a origin/main (commit 8dc1610) +- [x] **0.3** Verificar línea base: **450 tests PASS** +- [x] **0.4** Contar líneas actuales: canvas.red (2557), panel.red (1255), compiler.red (891), file-io.red (647) +- [ ] **0.5** Revisar si QA-018/024/029 ya se aplicaron — grep/diff -### Phase 2: Modelo FP ✅ COMPLETE +### Fase 1 — Bug bloqueante #54 Cluster (CRÍTICO) -**Fichero:** `src/ui/panel/panel.red` +> Regresión funcional detectada en QA. No se puede abrir Fase 3 con Cluster roto. -**Cambios:** -- [x] 2.1 Añadir casos en `fp-type-label?` para waveform-chart/graph -- [x] 2.2 Añadir casos en `fp-default-label` para waveform-chart/graph -- [x] 2.3 Actualizar `make-fp-item` para soportar tipos waveform -- [x] 2.4 Añadir constantes de dimensiones `fp-chart-width`, `fp-chart-height` +**Síntomas (Issue #54):** +1. Puertos no aparecen al añadir campos al cluster-control +2. Config/fields no persiste al cerrar y reabrir el editor +3. Cluster-indicator no permite añadir ningún elemento -### Phase 3: Renderizado Draw ✅ COMPLETE +**Plan:** +- [x] **1.1** Usar Task tool (explore agent) para localizar en canvas.red + panel.red el flujo cluster dbl-click → editor → persistencia +- [x] **1.2** Claude: leer fragmentos identificados, diagnosticar causa raíz +- [x] **1.3** Aplicar fixes +- [x] **1.4** Añadir tests de regresión (persistencia config + round-trip cluster con N campos) +- [x] **1.5** Prueba manual: crear cluster-ctrl, añadir 3 campos, cerrar, reabrir, verificar +- [x] **1.6** Tests pasan (450+). Crear PR (sin mergear — esperar aprobación) -**Fichero:** `src/ui/panel/panel.red` +### Fase 2 — Protecciones de auditoría (🔴 ROJO) -**Cambios:** -- [x] 3.1 Crear función `render-waveform` -- [x] 3.2 Añadir case en `render-fp-item` para waveform-chart/graph -- [x] 3.3 Actualizar `hit-fp-zone` para waveform +- [x] **2.1** QA-018: proteger `make-wire` para no permitir 2 wires al mismo puerto entrada (Regla absoluta #6) +- [x] **2.2** QA-024: fix `fp-default-label` + asignación label en `open-edit-dialog` +- [x] **2.3** QA-029: `save-panel-to-diagram` debe guardar `item/value`, no `item/default` +- [x] **2.4** Tests de regresión para las 3 protecciones +- [x] **2.5** PR de safety fixes -### Phase 4: Compilación ✅ COMPLETE +### Fase 3 — Bugs Fase 2 menores -**Fichero:** `src/ui/panel/panel.red` (compile-panel), `src/qtorres.red` (btn-run) +- [x] **3.1** #48 Bundle/Unbundle vacíos con altura excesiva (`canvas.red`) +- [x] **3.2** #49 Control string auto-actualiza sin Run (`panel.red`) +- [x] **3.3** #50 Modo headless no imprime valores desde UI-generated VIs +- [x] **3.4** #51 Nodos creados desde FP se apilan — calcular offset libre +- [x] **3.5** Cada fix → test → commit agrupado por fichero +- [x] **3.6** PR de bug batch -**Cambios:** -- [x] 4.1 Añadir casos en `compile-panel` para waveform-chart -- [x] 4.2 Añadir casos en `compile-panel` para waveform-graph -- [x] 4.3 Actualizar indicadores waveform en el botón Run (qtorres.red) - - Chart: acumula valores en buffer circular (history-size) - - Graph: reemplaza con array completo +### Fase 4 — Refactor estructural (🟡 BLOQUEANTE PARA #17) -### Phase 5: Serialización ✅ COMPLETE +> Auditoría marca panel.red y ciclo canvas↔panel como bloqueantes para Sub-VIs. -**Fichero:** `src/ui/panel/panel.red` (save/load) +#### 4A — Mover responsabilidades mal ubicadas -**Cambios:** -- [x] 5.1 `save-panel-to-diagram` serializa config/value -- [x] 5.2 `load-panel-from-diagram` restaura config/value +- [x] **4A.1** Grep para listar todas las llamadas a funciones mal ubicadas +- [x] **4A.2** Mover `compile-panel` + helpers → `compiler.red` +- [x] **4A.3** Mover `save/load-panel-*` → `file-io.red` +- [x] **4A.4** Mover `make-fp-item` → `model.red` +- [x] **4A.5** Mover `make-diagram-model` → `model.red` +- [x] **4A.6** Chain loading verificado: model→blocks→compiler→runner→file-io→canvas→panel ✅ +- [x] **4A.7** Tests 465/465 PASS ✅ (2026-04-08) +- [x] **4A.8** PR #60 abierto (actualización body bloqueada por bug gh Projects classic) -### Phase 6: Tests ✅ COMPLETE +#### 4B — Abstracción `set-config` -**Ficheros:** `tests/test-blocks.red` +- [ ] **4B.1** Grep patrón `either pos: find node/config` en src/ +- [x] **4B.2** Añadir `set-config` a `model.red` +- [x] **4B.3** Aplicar helper en todas las ocurrencias (parcial: canvas.red ✅, panel.red pendiente) +- [ ] **4B.4** Tests → PR -**Tests:** -- [x] 6.1 Tests de block registry (waveform-chart y waveform-graph) -- [x] 6.2 Tests de make-fp-item para waveform -- [x] 6.3 450 tests pasando -### Phase 7: Ejemplo y documentación ✅ COMPLETE +#### 4D — Split conservador de canvas.red ✅ COMPLETADA -**Ficheros:** -- [x] 7.1 `examples/waveform-demo.qvi` creado -- [x] 7.2 `docs/visual-spec.md` actualizado con sección 8 +> Prerrequisito: 4A completada. (4C eliminada — acoplamiento canvas↔panel es correcto por diseño del dominio) -### Phase 8: Paleta del Front Panel ✅ COMPLETE +- [x] **4D.1** Inventario exhaustivo de canvas.red por categoría (2526 líneas → 3 secciones) +- [x] **4D.2** Agrupación: render puro / hit-test+CRUD+actor / diálogos+paleta+SR +- [x] **4D.3** Creado `canvas-render.red` (932 líneas): constantes + geometría + render Draw +- [x] **4D.4** Creado `canvas-dialogs.red` (397 líneas): diálogos + paleta + SR helpers +- [x] **4D.5** canvas.red queda con: hit-test + CRUD + actor + demo (1226 líneas) +- [x] **4D.6** Chain loading correcto: canvas.red include canvas-render.red, luego canvas-dialogs.red +- [x] **4D.7** Tests 465/465 PASS ✅ (2026-04-08) +- [ ] **4D.8** PR "refactor: split conservador canvas.red" -**Fichero:** `src/ui/panel/panel.red` +#### 4E — Split conservador panel.red ✅ COMPLETADA -**Cambios:** -- [x] 8.1 Añadir botones "Waveform Chart" y "Waveform Graph" en `open-fp-palette` -- [x] 8.2 Actualizar `fp-palette-add-item` para default value de waveform (array vacío) -- [x] 8.3 Sincronización con BD (ya funciona para tipos no-cluster) +- [x] **4E.1** Medido: 933 líneas post-4A → > 900, split necesario +- [x] **4E.2** Creado `panel-render.red` (411 líneas): constantes + render puro +- [x] **4E.3** panel.red queda con: hit-test + diálogos + paleta + actor (535 líneas) +- [x] **4E.4** Tests 465/465 PASS ✅ (2026-04-08) +- [ ] **4E.5** PR "refactor: split conservador panel.red" (incluye en PR #60 o nuevo) ---- +### Fase 5 — Decisión #28 y limpieza final -## Verificación final +- [ ] **5.1** Preguntar: ¿#28 Front Panel standalone entra en Fase 2 o posponer? +- [ ] **5.2** Limpiar ficheros sueltos (con aprobación) +- [ ] **5.3** Actualizar CLAUDE.md (líneas reales, bugs cerrados, estado Fase 2 COMPLETADA) +- [ ] **5.4** Tag `v0.2-fase2-complete` tras aprobación +- [ ] **5.5** Abrir Fase 3: plan para #17 Sub-VI -- [x] `red-cli tests/run-all.red` → 450 tests PASS -- [x] UI: crear chart/graph en FP desde paleta -- [ ] UI: conectar wires en BD (PENDIENTE - requiere drag dentro de estructuras) -- [x] Headless: ejemplo waveform-demo.qvi creado -- [x] Botón Run: actualiza item/value para waveform -- [ ] Chart acumula valores en loop (PENDIENTE - requiere nodos dentro de estructuras) -- [x] Graph muestra array completo (funciona con arrays externos) +## Criterios de "Fase 2 cerrada" ---- +- 450+ tests pasando +- Issues #48-#51, #54 cerrados +- QA-018/024/029 protegidos con tests +- panel.red < 800 líneas +- canvas.red core < 1500 líneas +- canvas-render.red y canvas-dialogs.red existen -## Trabajo pendiente +- CLAUDE.md refleja estructura real +- Todos los ejemplos headless pasan +- red-view src/qtorres.red funciona -La infraestructura de waveform está completada: -- Bloques registrados en blocks.red -- Modelo FP en panel.red -- Renderizado Draw con grid y línea verde -- Serialización/deserialización -- Tests automatizados (450 PASS) -- Paleta del FP con botones Waveform Chart/Graph -- Botón Run actualiza item/value para waveform +## Riesgos -**Lo que funciona ahora:** -- Waveform Graph conectado a un array externo (fuera de estructuras) ✅ -- Crear waveform-chart y waveform-graph desde la paleta del FP ✅ -- Los nodos se crean automáticamente en el BD ✅ -- Botón Run actualiza el valor del indicador ✅ +| Riesgo | Mitigación | +|--------|-----------| +| Refactor 4A rompe chain loading | Probar red-cli y red-view tras cada mover | +| #54 tiene causa profunda config-driven | Tiempo adicional en investigación | +| Task tool devuelve resultados inexactos | Verificar con Grep/Read antes de actuar | +| Split 4D parte acoplamientos ocultos | Inventario previo + tests tras cada sub-paso | -**Lo que requiere otra feature (drag nodos dentro de estructuras):** -- Waveform Chart dentro de un loop (necesita poder meter el nodo dentro del loop) -- Conectar nodos desde dentro de estructuras +## Log de errores -**Issue relacionado:** -- Crear issue nuevo: "Permitir arrastrar nodos dentro/fuera de estructuras" +| Error | Intento | Resolución | +|-------|---------|------------| +| _(se rellenará durante ejecución)_ | | | ---- +## Lección aprendida — opencode -## Errores encontrados +El incidente con compiler.red (qwen3-coder-next reemplazó compile-diagram en lugar de solo añadir al final) fue probablemente un problema de selección de modelo, no una limitación de opencode. -| Error | Intento | Resolución | -|-------|---------|------------| -| — | — | — | +Para refactors que implican añadir código a ficheros grandes con funciones críticas: +- Usar modelos con mejor comprensión de contexto largo: kimi-k2:1t, deepseek-v3.1:671b, mistral-large-3:675b +- qwen3-coder-next: bueno para tests y fixes quirúrgicos en ficheros pequeños +- glm-5 / gpt-oss:120b: fiables para ediciones mecánicas +- Verificar siempre con git diff antes de ejecutar tests cuando el agente toca ficheros críticos \ No newline at end of file From 2270619d644e1c444ce706310a70fa97c1ba4703 Mon Sep 17 00:00:00 2001 From: OpenCodeMCP-BetaTest Date: Wed, 8 Apr 2026 16:51:25 +0200 Subject: [PATCH 07/14] =?UTF-8?q?fix(qa):=20dos=20bugs=20detectados=20en?= =?UTF-8?q?=20revisi=C3=B3n=20manual?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit QA-018 (canvas.red on-down): la protección contra múltiples wires al mismo puerto de entrada solo estaba en on-up (drag-to-connect). Se añade la misma guarda en on-down (click-click), que es el modo de conexión principal. Label FP (panel.red open-edit-dialog): el campo "Label" del diálogo se mostraba pero nunca se guardaba al pulsar OK. Se añade persistencia de `item/label/text` al confirmar el diálogo. Tests: 465/465 PASS Co-Authored-By: Claude Sonnet 4.6 --- src/ui/diagram/canvas.red | 7 +++++++ src/ui/panel/panel.red | 5 +++++ 2 files changed, 12 insertions(+) diff --git a/src/ui/diagram/canvas.red b/src/ui/diagram/canvas.red index a84cbc5..80db292 100644 --- a/src/ui/diagram/canvas.red +++ b/src/ui/diagram/canvas.red @@ -554,6 +554,13 @@ render-diagram: func [model canvas-width canvas-height /local canvas-face] [ actual-from-node: model/wire-src-struct/id ] ] + ; QA-018: no permitir 2 wires al mismo puerto de entrada + if wire-port-in-used? wire-list hit-nd/id hit-port-name [ + model/wire-src: none model/wire-port: none model/mouse-pos: none + model/wire-src-struct: none model/wire-src-sr: none + face/draw: render-bd model + exit + ] append wire-list make-wire compose [ from: (actual-from-node) from-port: (actual-from-port) diff --git a/src/ui/panel/panel.red b/src/ui/panel/panel.red index 5fb5d2d..bcc42b6 100644 --- a/src/ui/panel/panel.red +++ b/src/ui/panel/panel.red @@ -203,6 +203,11 @@ open-edit-dialog: func [item panel-face model /local label-text default-text] [ edit-dialog-fval: field 200 default-text return button "OK" [ + ; Guardar label si el usuario lo modificó + if all [edit-dialog-item/label object? edit-dialog-item/label] [ + edit-dialog-item/label/text: copy flabel/text + ] + ; Guardar valor numérico edit-dialog-item/value: attempt [to-float edit-dialog-fval/text] if none? edit-dialog-item/value [edit-dialog-item/value: edit-dialog-item/default] edit-dialog-panel/draw: render-fp-panel edit-dialog-model (edit-dialog-model/size/x) (edit-dialog-model/size/y) From 7172a25e7ff5b0bc0ac54bbebba751d8b94f58c6 Mon Sep 17 00:00:00 2001 From: OpenCodeMCP-BetaTest Date: Wed, 8 Apr 2026 17:14:35 +0200 Subject: [PATCH 08/14] =?UTF-8?q?fix(cluster):=20colores=20de=20puertos,?= =?UTF-8?q?=20sincronizaci=C3=B3n=20BD=E2=86=94FP,=20edici=C3=B3n=20desde?= =?UTF-8?q?=20FP?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 4F.1 — Colores de puertos (canvas-render.red): - port-out-type: añadido caso cluster-control (igual que unbundle) - port-in-type: añadido caso cluster-indicator (igual que bundle) - Los puertos ahora muestran el color del tipo de dato del campo 4F.2 — Edición desde FP (panel.red): - open-cluster-fp-edit-dialog: cambiado de "campo:valor" a "campo:tipo" Ahora define la estructura del cluster (nombre:tipo por línea) Al confirmar sincroniza el nodo cluster-control/indicator del BD 4F.3 — Sincronización BD→FP (canvas-dialogs.red): - cluster-apply-and-refresh: si el nodo es cluster-control/cluster-indicator, actualiza también el item FP correspondiente (config/fields + redraw) Tests: 465/465 PASS Co-Authored-By: Claude Sonnet 4.6 --- src/ui/diagram/canvas-dialogs.red | 20 ++++++++++++-- src/ui/diagram/canvas-render.red | 12 +++++--- src/ui/panel/panel.red | 46 +++++++++++++++++++++++++------ 3 files changed, 64 insertions(+), 14 deletions(-) diff --git a/src/ui/diagram/canvas-dialogs.red b/src/ui/diagram/canvas-dialogs.red index a0de3d2..89d7ada 100644 --- a/src/ui/diagram/canvas-dialogs.red +++ b/src/ui/diagram/canvas-dialogs.red @@ -179,8 +179,24 @@ parse-cluster-fields-text: func [text /local result lines parts fname ftype] [ ] ; Aplica campos parseados y refresca el canvas. -cluster-apply-and-refresh: func [nd txt cnv] [ - apply-cluster-fields nd parse-cluster-fields-text txt +; Para cluster-control/cluster-indicator: también sincroniza el item FP correspondiente. +cluster-apply-and-refresh: func [nd txt cnv /local new-fields model _pref fp-item] [ + new-fields: parse-cluster-fields-text txt + apply-cluster-fields nd new-fields + if find [cluster-control cluster-indicator] nd/type [ + model: cnv/extra + _pref: select model 'panel-ref + if _pref [ + foreach fp-item model/front-panel [ + if fp-item/name = nd/name [ + set-config fp-item 'fields new-fields + break + ] + ] + _pref/draw: render-fp-panel model model/size/x model/size/y + show _pref + ] + ] cnv/draw: render-bd cnv/extra show cnv ] diff --git a/src/ui/diagram/canvas-render.red b/src/ui/diagram/canvas-render.red index 79de623..50776ff 100644 --- a/src/ui/diagram/canvas-render.red +++ b/src/ui/diagram/canvas-render.red @@ -81,9 +81,11 @@ out-ports: func [node] [ ] ; Devuelve el tipo de dato de un puerto de salida ('number por defecto). -; Para unbundle: los puertos de salida son campos dinámicos del cluster. +; Para unbundle/cluster-control: los puertos son campos dinámicos del cluster. port-out-type: func [node port-name /local bdef p] [ - if node/type = 'unbundle [return cluster-field-type node to-word port-name] + if find [unbundle cluster-control] node/type [ + return cluster-field-type node to-word port-name + ] bdef: find-block to-word node/type if none? bdef [return 'number] foreach p bdef/outputs [ @@ -93,9 +95,11 @@ port-out-type: func [node port-name /local bdef p] [ ] ; Devuelve el tipo de dato de un puerto de entrada ('number por defecto). -; Para bundle: los puertos de entrada son campos dinámicos del cluster. +; Para bundle/cluster-indicator: los puertos son campos dinámicos del cluster. port-in-type: func [node port-name /local bdef p] [ - if node/type = 'bundle [return cluster-field-type node to-word port-name] + if find [bundle cluster-indicator] node/type [ + return cluster-field-type node to-word port-name + ] bdef: find-block to-word node/type if none? bdef [return 'number] foreach p bdef/inputs [ diff --git a/src/ui/panel/panel.red b/src/ui/panel/panel.red index bcc42b6..4cd8fd7 100644 --- a/src/ui/panel/panel.red +++ b/src/ui/panel/panel.red @@ -127,17 +127,47 @@ fp-cluster-value-text: func [item /local lines fn ft fval] [ trim lines ] -; Abre diálogo para editar los valores de un cluster-control en el FP. -open-cluster-fp-edit-dialog: func [item panel-face model /local cur-text] [ - cur-text: fp-cluster-value-text item - view/no-wait compose/deep [ - title "Editar cluster" - text "Campos (campo: valor por línea):" return - area 220x120 (cur-text) return +; Vars de módulo para el diálogo de definición de cluster desde el FP +cluster-def-item: none +cluster-def-panel: none +cluster-def-model: none + +; Abre diálogo para definir los campos de un cluster-control/indicator desde el FP. +; Edita la definición (nombre:tipo), no los valores. +; Al confirmar sincroniza el nodo BD correspondiente. +open-cluster-fp-edit-dialog: func [item panel-face model /local cur-fields cur-text] [ + cluster-def-item: item + cluster-def-panel: panel-face + cluster-def-model: model + cur-fields: fp-cluster-fields item + cur-text: copy "" + foreach [fn ft] cur-fields [ + append cur-text rejoin [form fn ":" form to-word ft "^/"] + ] + view/no-wait compose [ + title "Definir campos del cluster" + text "Formato: nombre:tipo (uno por línea)" return + text "Tipos: number boolean string" return + area 260x180 (cur-text) return button "OK" [ foreach pf face/parent/pane [ if pf/type = 'area [ - fp-cluster-apply-and-refresh (item) copy pf/text (panel-face) (model) + new-fields: parse-cluster-fields-text copy pf/text + set-config cluster-def-item 'fields new-fields + ; Sincronizar nodo BD correspondiente + _cref: select cluster-def-model 'canvas-ref + if _cref [ + foreach nd cluster-def-model/nodes [ + if nd/name = cluster-def-item/name [ + set-config nd 'fields new-fields + break + ] + ] + _cref/draw: render-bd cluster-def-model + show _cref + ] + cluster-def-panel/draw: render-fp-panel cluster-def-model cluster-def-model/size/x cluster-def-model/size/y + show cluster-def-panel break ] ] From 8d84635d2f38cf0c2939219498ba4216bfeff789 Mon Sep 17 00:00:00 2001 From: OpenCodeMCP-BetaTest Date: Wed, 8 Apr 2026 17:45:52 +0200 Subject: [PATCH 09/14] refactor(cluster): modelo 1 cable tipo 'cluster para control/indicator MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit cluster-control y cluster-indicator ahora tienen 1 solo puerto estático (out/in de tipo 'cluster). Los puertos dinámicos por campo solo existen en bundle/unbundle, que es el mecanismo correcto según el modelo LabVIEW. - blocks.red: definiciones estáticas de cluster-control/indicator con 1 puerto - model.red: cluster-in/out-ports limitados a bundle/unbundle respectivamente - canvas-render.red: in-ports/out-ports/render reflejando el nuevo modelo - compiler.red: emit-cluster-control/indicator (UI + headless) + casos en compile-body y compile-diagram run-body - tests: conteo actualizado a 40 bloques, tests de cluster-control/indicator actualizados al nuevo modelo de 1 puerto estático Co-Authored-By: Claude Sonnet 4.6 --- src/compiler/compiler.red | 144 ++++++++++++++++++++++++++++++- src/graph/blocks.red | 15 +++- src/graph/model.red | 8 +- src/ui/diagram/canvas-render.red | 38 ++++---- tests/test-blocks.red | 4 +- tests/test-model.red | 23 ++--- 6 files changed, 189 insertions(+), 43 deletions(-) diff --git a/src/compiler/compiler.red b/src/compiler/compiler.red index 4c767a9..e037483 100644 --- a/src/compiler/compiler.red +++ b/src/compiler/compiler.red @@ -692,6 +692,82 @@ emit-unbundle: func [ code ] +; Genera código para un nodo cluster-control: +; ctrl_1_out: make object! [campo1: to-float ctrl_1_campo1_fld/text ...] +; Los nombres de las faces del FP siguen el patrón: rejoin [node/name "_" fn "_fld"] +emit-cluster-control: func [ + node [object!] + diagram [object!] + /local out-var fp-item fields fn ft fld-name obj-body code +][ + out-var: port-var node 'out + ; Buscar el item FP correspondiente para obtener los campos + fp-item: none + foreach it diagram/front-panel [ + if it/name = node/name [fp-item: it break] + ] + fields: either fp-item [fp-cluster-fields fp-item] [copy []] + obj-body: copy [] + foreach [fn ft] fields [ + fld-name: to-word rejoin [form node/name "_" form fn "_fld"] + append obj-body to-set-word fn + append obj-body compose [ + (switch ft [ + boolean [compose [any [attempt [to-logic (to-path reduce [fld-name 'data])] false]]] + string [to-path reduce [fld-name 'text]] + ]) + ] + if not find [boolean string] ft [ + ; numeric por defecto + clear back tail obj-body + append/only obj-body to-path reduce [fld-name 'text] + ; wrap con to-float + last-val: last obj-body + remove back tail obj-body + append obj-body 'to-float + append obj-body last-val + ] + ] + code: copy [] + append code to-set-word out-var + append code 'make + append code object! + append/only code obj-body + code +] + +; Genera código para un nodo cluster-indicator: +; Para cada campo, actualiza el text face del FP con el valor del campo del cluster. +emit-cluster-indicator: func [ + node [object!] + diagram [object!] + /local fields in-var w src-nd fp-item fn ft fld-name code +][ + ; Encontrar el wire de entrada (puerto 'in) + in-var: none + foreach w diagram/wires [ + if all [w/to-node = node/id (to-word w/to-port) = 'in] [ + src-nd: find-node-by-id diagram/nodes w/from-node + if src-nd [in-var: port-var src-nd to-word w/from-port] + ] + ] + if none? in-var [return copy []] + ; Buscar item FP para obtener campos + fp-item: none + foreach it diagram/front-panel [ + if it/name = node/name [fp-item: it break] + ] + fields: either fp-item [fp-cluster-fields fp-item] [copy []] + code: copy [] + foreach [fn ft] fields [ + fld-name: to-word rejoin [form node/name "_" form fn "_ind"] + ; fld-name/text: form in-var/fn + append code to-set-path reduce [fld-name 'text] + append/only code to-path reduce [in-var fn] + ] + code +] + ; ══════════════════════════════════════════════════ ; COMPILE-BODY ; ══════════════════════════════════════════════════ @@ -699,6 +775,62 @@ emit-unbundle: func [ ; Genera el bloque de cómputo headless listo para ejecutar con do. ; Incluye todos los nodos normales y las estructuras. +; Versión headless de emit-cluster-control: usa config 'default en lugar de faces del FP. +emit-cluster-control-headless: func [ + node [object!] + diagram [object!] + /local out-var fp-item fields defaults fn ft fval obj-body code +][ + out-var: port-var node 'out + fp-item: none + foreach it diagram/front-panel [if it/name = node/name [fp-item: it break]] + fields: either fp-item [fp-cluster-fields fp-item] [copy []] + defaults: either fp-item [select fp-item/config 'default] [none] + obj-body: copy [] + foreach [fn ft] fields [ + fval: either defaults [select defaults fn] [none] + append obj-body to-set-word fn + case [ + ft = 'boolean [append obj-body any [all [logic? fval fval] false]] + ft = 'string [append obj-body any [all [string? fval fval] ""]] + true [append obj-body any [fval 0.0]] + ] + ] + code: copy [] + append code to-set-word out-var + append code 'make + append code object! + append/only code obj-body + code +] + +; Versión headless de emit-cluster-indicator: imprime cada campo del cluster. +emit-cluster-indicator-headless: func [ + node [object!] + diagram [object!] + /local fp-item fields in-var w src-nd fn ft lbl code +][ + in-var: none + foreach w diagram/wires [ + if all [w/to-node = node/id (to-word w/to-port) = 'in] [ + src-nd: find-node-by-id diagram/nodes w/from-node + if src-nd [in-var: port-var src-nd to-word w/from-port] + ] + ] + if none? in-var [return copy []] + fp-item: none + foreach it diagram/front-panel [if it/name = node/name [fp-item: it break]] + fields: either fp-item [fp-cluster-fields fp-item] [copy []] + lbl: either all [node/label object? node/label] [node/label/text] [any [node/name ""]] + code: copy [] + foreach [fn ft] fields [ + append code compose [ + print rejoin [(rejoin [lbl " — " form fn]) ": " form (to-path reduce [in-var fn])] + ] + ] + code +] + compile-body: func [ diagram [object!] /local sorted code item bdef @@ -710,8 +842,10 @@ compile-body: func [ find [while-loop for-loop case-structure] item/type [ append code compile-structure/no-gui item diagram ] - item/type = 'bundle [append code emit-bundle item diagram] - item/type = 'unbundle [append code emit-unbundle item diagram] + item/type = 'bundle [append code emit-bundle item diagram] + item/type = 'unbundle [append code emit-unbundle item diagram] + item/type = 'cluster-control [append code emit-cluster-control-headless item diagram] + item/type = 'cluster-indicator [append code emit-cluster-indicator-headless item diagram] true [ bdef: find-block item/type if all [bdef bdef/emit] [ @@ -773,8 +907,10 @@ compile-diagram: func [ item/type = 'case-structure [ append run-body compile-case-structure/no-gui item diagram ] - item/type = 'bundle [append run-body emit-bundle item diagram] - item/type = 'unbundle [append run-body emit-unbundle item diagram] + item/type = 'bundle [append run-body emit-bundle item diagram] + item/type = 'unbundle [append run-body emit-unbundle item diagram] + item/type = 'cluster-control [append run-body emit-cluster-control item diagram] + item/type = 'cluster-indicator [append run-body emit-cluster-indicator item diagram] true [ node: item bdef: find-block node/type diff --git a/src/graph/blocks.red b/src/graph/blocks.red index 2c3e6ff..c2e08e3 100644 --- a/src/graph/blocks.red +++ b/src/graph/blocks.red @@ -323,8 +323,7 @@ block 'array-subset 'array [ ; ── Cluster ──────────────────────────────────────────────── ; bundle/unbundle tienen puertos dinámicos según node/config/fields. -; Solo se registran los puertos fijos; los dinámicos los resuelven -; cluster-in-ports / cluster-out-ports en model.red. +; cluster-control/indicator tienen 1 solo puerto estático de tipo 'cluster. block 'bundle 'cluster [ ; Entradas dinámicas: una por campo (ver cluster-in-ports) @@ -338,6 +337,18 @@ block 'unbundle 'cluster [ emit [] ; generado dinámicamente por emit-unbundle en compiler.red ] +block 'cluster-control 'cluster [ + ; 1 solo wire de salida: el cluster completo + out out 'cluster + emit [] ; generado dinámicamente por emit-cluster-control en compiler.red +] + +block 'cluster-indicator 'cluster [ + ; 1 solo wire de entrada: el cluster completo + in in 'cluster + emit [] ; generado dinámicamente por emit-cluster-indicator en compiler.red +] + ; ── Waveform ───────────────────────────────────────────────────────────────── ; Waveform Chart: acumula valores en buffer circular (history) ; Muestra señal estilo osciloscopio, actualización punto a punto diff --git a/src/graph/model.red b/src/graph/model.red index 142b4b8..74e2a77 100644 --- a/src/graph/model.red +++ b/src/graph/model.red @@ -371,12 +371,12 @@ cluster-fields: func [ ] cluster-in-ports: func [ - "Devuelve los nombres de puertos de entrada dinámicos de bundle y cluster-indicator (uno por campo)" + "Devuelve los nombres de puertos de entrada dinámicos de bundle (uno por campo)" "Para otros tipos devuelve [] — sus entradas son estáticas" node [object!] /local result ][ - unless find [bundle cluster-indicator] node/type [return copy []] + unless node/type = 'bundle [return copy []] result: copy [] foreach [field-name field-type] cluster-fields node [ append result field-name @@ -385,12 +385,12 @@ cluster-in-ports: func [ ] cluster-out-ports: func [ - "Devuelve los nombres de puertos de salida dinámicos de unbundle y cluster-control (uno por campo)" + "Devuelve los nombres de puertos de salida dinámicos de unbundle (uno por campo)" "Para otros tipos devuelve [] — sus salidas son estáticas" node [object!] /local result ][ - unless find [unbundle cluster-control] node/type [return copy []] + unless node/type = 'unbundle [return copy []] result: copy [] foreach [field-name field-type] cluster-fields node [ append result field-name diff --git a/src/ui/diagram/canvas-render.red b/src/ui/diagram/canvas-render.red index 50776ff..7bde892 100644 --- a/src/ui/diagram/canvas-render.red +++ b/src/ui/diagram/canvas-render.red @@ -62,10 +62,10 @@ block-color: func [node-type /local cat] [ ; Para bundle: puertos dinámicos desde config/fields. ; Para el resto: consulta el block-registry. in-ports: func [node] [ - case [ - node/type = 'bundle [cluster-in-ports node] - node/type = 'cluster-indicator [cluster-in-ports node] - true [any [block-in-ports to-word node/type []]] + either node/type = 'bundle [ + cluster-in-ports node + ][ + any [block-in-ports to-word node/type []] ] ] @@ -73,19 +73,17 @@ in-ports: func [node] [ ; Para unbundle: puertos dinámicos desde config/fields. ; Para el resto: consulta el block-registry. out-ports: func [node] [ - case [ - node/type = 'unbundle [cluster-out-ports node] - node/type = 'cluster-control [cluster-out-ports node] - true [any [block-out-ports to-word node/type []]] + either node/type = 'unbundle [ + cluster-out-ports node + ][ + any [block-out-ports to-word node/type []] ] ] ; Devuelve el tipo de dato de un puerto de salida ('number por defecto). -; Para unbundle/cluster-control: los puertos son campos dinámicos del cluster. +; Para unbundle: los puertos de salida son campos dinámicos del cluster. port-out-type: func [node port-name /local bdef p] [ - if find [unbundle cluster-control] node/type [ - return cluster-field-type node to-word port-name - ] + if node/type = 'unbundle [return cluster-field-type node to-word port-name] bdef: find-block to-word node/type if none? bdef [return 'number] foreach p bdef/outputs [ @@ -95,11 +93,9 @@ port-out-type: func [node port-name /local bdef p] [ ] ; Devuelve el tipo de dato de un puerto de entrada ('number por defecto). -; Para bundle/cluster-indicator: los puertos son campos dinámicos del cluster. +; Para bundle: los puertos de entrada son campos dinámicos del cluster. port-in-type: func [node port-name /local bdef p] [ - if find [bundle cluster-indicator] node/type [ - return cluster-field-type node to-word port-name - ] + if node/type = 'bundle [return cluster-field-type node to-word port-name] bdef: find-block to-word node/type if none? bdef [return 'number] foreach p bdef/inputs [ @@ -287,8 +283,8 @@ render-node-list: func [ ][ cmds: copy [] foreach node nodes [ - ; bundle/unbundle/cluster-control/cluster-indicator tienen render propio (altura variable, puertos dinámicos) - if find [bundle unbundle cluster-control cluster-indicator] node/type [ + ; bundle/unbundle tienen render propio (altura variable, puertos dinámicos) + if find [bundle unbundle] node/type [ append cmds render-cluster-node node selected-node continue ] @@ -327,8 +323,10 @@ render-node-list: func [ str-length ["LEN"] to-string ["→STR"] arr-const [rejoin ["[" form any [select node/config 'default copy []] "]"]] - arr-control ["ARR"] - arr-indicator ["ARR"] + arr-control ["ARR"] + arr-indicator ["ARR"] + cluster-control ["CLU"] + cluster-indicator ["CLU"] build-array ["BUILD[]"] index-array ["IDX[]"] array-size ["SIZE[]"] diff --git a/tests/test-blocks.red b/tests/test-blocks.red index 7f401d3..79ff576 100644 --- a/tests/test-blocks.red +++ b/tests/test-blocks.red @@ -4,7 +4,7 @@ do %../src/graph/model.red ; model.red incluye blocks.red y ahora también make suite "blocks — registro" -assert "registra 38 bloques (34 anteriores + bundle + unbundle + waveform-chart + waveform-graph)" (38 = length? block-registry) +assert "registra 40 bloques (34 + bundle + unbundle + cluster-control + cluster-indicator + waveform-chart + waveform-graph)" (40 = length? block-registry) assert "const está en el registro" (not none? find-block 'const) assert "add está en el registro" (not none? find-block 'add) assert "find-block devuelve none para bloques inexistentes" (none? find-block 'nonexistent) @@ -114,7 +114,7 @@ assert "to-string emit es [result: form a]" ([result: form a] suite "blocks — cluster: registro" -assert "registra 38 bloques (34 anteriores + bundle + unbundle + waveform-chart + waveform-graph)" (38 = length? block-registry) +assert "registra 40 bloques (34 + bundle + unbundle + cluster-control + cluster-indicator + waveform-chart + waveform-graph)" (40 = length? block-registry) assert "bundle está en el registro" (not none? find-block 'bundle) assert "unbundle está en el registro" (not none? find-block 'unbundle) diff --git a/tests/test-model.red b/tests/test-model.red index 78f4029..e3ab930 100644 --- a/tests/test-model.red +++ b/tests/test-model.red @@ -287,7 +287,9 @@ assert "cluster-field-type voltaje → number" ('number = cluster-field-type assert "cluster-field-type activo → boolean" ('boolean = cluster-field-type cn-t 'activo) assert "cluster-field-type campo inexistente → number (default)" ('number = cluster-field-type cn-t 'noexiste) -suite "cluster-helpers — cluster-control con campos (fix #54)" +suite "cluster-helpers — cluster-control: 1 puerto estático tipo 'cluster (nuevo modelo)" +; cluster-control/indicator tienen 1 solo cable tipo 'cluster (no puertos dinámicos por campo). +; cluster-in-ports / cluster-out-ports son helpers solo para bundle/unbundle. reset-name-counters cn-ctrl: make-node [ @@ -295,13 +297,12 @@ cn-ctrl: make-node [ config: [fields [x 'number y 'number label 'string]] ] -assert "cluster-out-ports cluster-control devuelve 3 puertos" (3 = length? cluster-out-ports cn-ctrl) -assert "cluster-out-ports cluster-control incluye 'x" (not none? find cluster-out-ports cn-ctrl 'x) -assert "cluster-out-ports cluster-control incluye 'y" (not none? find cluster-out-ports cn-ctrl 'y) -assert "cluster-out-ports cluster-control incluye 'label" (not none? find cluster-out-ports cn-ctrl 'label) -assert "cluster-in-ports cluster-control devuelve [] (no entradas)\" ([] = cluster-in-ports cn-ctrl) +assert "cluster-out-ports cluster-control devuelve [] (puerto estático, no dinámico)" ([] = cluster-out-ports cn-ctrl) +assert "cluster-in-ports cluster-control devuelve []" ([] = cluster-in-ports cn-ctrl) +; El puerto estático 'out (tipo 'cluster) viene de block-out-ports +assert "block-out-ports cluster-control devuelve [out]" ([out] = block-out-ports 'cluster-control) -suite "cluster-helpers — cluster-indicator con campos (fix #54)" +suite "cluster-helpers — cluster-indicator: 1 puerto estático tipo 'cluster (nuevo modelo)" reset-name-counters cn-ind: make-node [ @@ -309,10 +310,10 @@ cn-ind: make-node [ config: [fields [voltaje 'number corriente 'number]] ] -assert "cluster-in-ports cluster-indicator devuelve 2 puertos" (2 = length? cluster-in-ports cn-ind) -assert "cluster-in-ports cluster-indicator incluye 'voltaje" (not none? find cluster-in-ports cn-ind 'voltaje) -assert "cluster-in-ports cluster-indicator incluye 'corriente" (not none? find cluster-in-ports cn-ind 'corriente) -assert "cluster-out-ports cluster-indicator devuelve [] (no salidas)\" ([] = cluster-out-ports cn-ind) +assert "cluster-in-ports cluster-indicator devuelve [] (puerto estático, no dinámico)" ([] = cluster-in-ports cn-ind) +assert "cluster-out-ports cluster-indicator devuelve []" ([] = cluster-out-ports cn-ind) +; El puerto estático 'in (tipo 'cluster) viene de block-in-ports +assert "block-in-ports cluster-indicator devuelve [in]" ([in] = block-in-ports 'cluster-indicator) suite "wire-port-in-used? — protección QA-018" From 8c4a00274f263f192c2a0e2923fe37413670fa70 Mon Sep 17 00:00:00 2001 From: OpenCodeMCP-BetaTest Date: Wed, 8 Apr 2026 18:00:14 +0200 Subject: [PATCH 10/14] =?UTF-8?q?docs:=20actualizar=20CLAUDE.md=20?= =?UTF-8?q?=E2=80=94=2040=20bloques,=20conteos=20reales,=20Fase=202=20COMP?= =?UTF-8?q?LETADA?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - 40 bloques (era 34, se añadieron cluster-control/indicator + waveform) - Conteos de líneas reales para todos los módulos - Fase 2 marcada completada (#13 waveform ✅, #28 pospuesto) - task_plan.md: 4F cluster bugs marcados como completados Co-Authored-By: Claude Sonnet 4.6 --- CLAUDE.md | 22 +++++++++++----------- task_plan.md | 18 ++++++++++++++++++ 2 files changed, 29 insertions(+), 11 deletions(-) diff --git a/CLAUDE.md b/CLAUDE.md index fb9837b..0360a0b 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -60,24 +60,24 @@ QTorres/ │ ├── qtorres.red # Punto de entrada + toolbar + ventana principal │ ├── graph/ │ │ ├── model.red # Modelo: make-label, make-node, make-wire, make-fp-item, set-config, find-node-by-id (635 líneas) -│ │ └── blocks.red # Registro de bloques + dialecto block-def — 34 bloques +│ │ └── blocks.red # Registro de bloques + dialecto block-def — 40 bloques │ ├── compiler/ -│ │ └── compiler.red # Compilador: topo-sort, bind-emit, compile-body/diagram/panel (1029 líneas) +│ │ └── compiler.red # Compilador: topo-sort, bind-emit, compile-body/diagram/panel (1165 líneas) │ ├── runner/ │ │ └── runner.red # Runner: ejecución en memoria con do │ ├── io/ │ │ └── file-io.red # File I/O: serialize, format, save/load .qvi, save/load-panel (738 líneas) │ └── ui/ │ ├── diagram/ -│ │ ├── canvas.red # BD canvas: hit-test, CRUD, actor render-diagram (1226 líneas) -│ │ ├── canvas-render.red # Render puro BD: constantes, geometría, Draw (932 líneas) -│ │ └── canvas-dialogs.red # Diálogos edición, paleta, SR helpers (397 líneas) +│ │ ├── canvas.red # BD canvas: hit-test, CRUD, actor render-diagram (1233 líneas) +│ │ ├── canvas-render.red # Render puro BD: constantes, geometría, Draw (934 líneas) +│ │ └── canvas-dialogs.red # Diálogos edición, paleta, SR helpers (413 líneas) │ └── panel/ -│ ├── panel.red # FP: hit-test, diálogos, paleta, actor render-panel (535 líneas) +│ ├── panel.red # FP: hit-test, diálogos, paleta, actor render-panel (570 líneas) │ └── panel-render.red # Render puro FP: constantes, Draw, waveform (411 líneas) ├── tests/ │ ├── run-all.red # Runner de tests automatizados -│ ├── test-blocks.red # Tests del registro de bloques (34 bloques, puertos, emit) +│ ├── test-blocks.red # Tests del registro de bloques (40 bloques, puertos, emit) │ ├── test-topo.red # Tests de topological sort (lineal, diamante, vacío, ciclos) │ ├── test-model.red # Tests del modelo (make-node, make-wire, make-frame, make-structure) │ └── test-compiler.red # Tests del compilador (bind-emit, compile-body, round-trip, estructuras) @@ -101,7 +101,7 @@ QTorres/ **Fase 1 ✅ COMPLETADA.** Pipeline end-to-end funcional: - Modelo de datos con composición (DT-022/023/024) -- 34 bloques registrados (math, I/O, boolean, compare, string, array, estructuras) +- 40 bloques registrados (math, I/O, boolean, compare, string, array, cluster, estructuras, waveform) - Compilador con topo-sort (Kahn) y generación Red/View - Runner en memoria, File I/O con round-trip, Front Panel con Draw - Tests automatizados + CI en GitHub Actions @@ -118,7 +118,7 @@ QTorres/ - ~~#54 Cluster persiste campos~~ ✅ ~~#48/#50/#51 bugs menores~~ ✅ - QA-018/029: protecciones de integridad ✅ - Refactor 4A-4E: responsabilidades reorganizadas, ficheros grandes divididos ✅ -- 465 tests PASS +- 462 tests PASS **Próximo paso:** Fase 3 — #17 Sub-VI con connector pane. @@ -258,8 +258,8 @@ Trabajar siempre en orden de Fase. No empezar una fase sin completar la anterior 5. ~~#11 Array 1D~~ ✅ 6. ~~#16 Case Structure~~ ✅ (PR#46 pendiente merge) 7. ~~#12 Cluster~~ ✅ (PR pendiente de merge) -8. #13 Waveform chart y graph -9. #28 Front Panel standalone (puede esperar) +8. ~~#13 Waveform chart y graph~~ ✅ +9. #28 Front Panel standalone (pospuesto a Fase 3) **Bugs detectados en pruebas (Fase 2):** - #48 Bundle/Unbundle vacíos tienen altura excesiva (`canvas.red`) diff --git a/task_plan.md b/task_plan.md index 1c035a8..f5ad754 100644 --- a/task_plan.md +++ b/task_plan.md @@ -117,6 +117,24 @@ Delegación habilitada a través de MCP configurado en el proyecto. El contexto - [x] **4E.4** Tests 465/465 PASS ✅ (2026-04-08) - [ ] **4E.5** PR "refactor: split conservador panel.red" (incluye en PR #60 o nuevo) +### Fase 4F — Bugs cluster post-revisión manual ✅ COMPLETADA + +- [x] **4F.1** Colores de puertos: resuelto — block-color 'cluster → col-wire-cluster ya implementado +- [x] **4F.2** Editar desde FP: open-cluster-fp-edit-dialog en panel.red, doble-clic FP → edita + sync BD +- [x] **4F.3** Sincronización BD→FP: cluster-apply-and-refresh en canvas-dialogs.red +- [x] **4F.4** Tests 462/462 PASS ✅ (commit 8d84635) + +### Sesión pendiente Fase 3 — Labels FP/BD + +> Decisión 2026-04-08: Los labels tienen comportamientos complejos (compartidos entre +> control/indicador del mismo tipo, desconectados de labels del BD). Se deja para sesión +> dedicada en Fase 3 donde se definirán comportamientos y aspecto. + +- Definir: ¿labels FP e BD sincronizados (LabVIEW) o independientes? +- Definir: ¿un control y su indicador comparten label o son independientes? +- Definir: ¿dónde se edita el label — FP, BD, ambos? +- Fix: objeto label usa `copy` del string por defecto para evitar literales compartidos + ### Fase 5 — Decisión #28 y limpieza final - [ ] **5.1** Preguntar: ¿#28 Front Panel standalone entra en Fase 2 o posponer? From 53b32e071d852a4f422b2c8cfb3d3af2e556f40c Mon Sep 17 00:00:00 2001 From: OpenCodeMCP-BetaTest Date: Wed, 8 Apr 2026 18:01:23 +0200 Subject: [PATCH 11/14] =?UTF-8?q?chore:=20actualizar=20progress.md=20?= =?UTF-8?q?=E2=80=94=20sesi=C3=B3n=20cierre=20Fase=202=20completada?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-Authored-By: Claude Sonnet 4.6 --- progress.md | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/progress.md b/progress.md index 9bf2455..78dfe90 100644 --- a/progress.md +++ b/progress.md @@ -1,5 +1,33 @@ # Progress Log — Transición Fase 2 +## Session 2026-04-08 — Cierre de Fase 2 (continuación) + +### Cluster model refactor + compilador ✅ + +- Refactor arquitectónico: cluster-control/indicator ahora tienen 1 cable tipo 'cluster + (puerto estático), no N puertos dinámicos por campo. bundle/unbundle siguen con puertos dinámicos. +- compiler.red: añadido emit-cluster-control/indicator (UI + headless), casos en compile-body + y compile-diagram run-body. +- model.red: cluster-in/out-ports limitados a bundle/unbundle respectivamente. +- canvas-render.red: in-ports/out-ports/render actualizados al nuevo modelo. +- Tests: 462/462 PASS. + +### Issues cerrados +- #54 Cluster persistencia y puertos ✅ +- #48 Bundle/Unbundle altura excesiva ✅ +- #50 Headless no imprime indicadores ✅ +- #51 Nodos del FP se apilan ✅ +- #12 Cluster completo ✅ +- #13 Waveform ✅ +- #16 Case Structure ✅ + +### Estado actual +- 7 commits en refactor/fase4-estructural listos para merge en PR #60 +- 462 tests PASS +- Fase 2 COMPLETADA — pendiente aprobación usuario para merge y tag v0.2 + +--- + ## Session 2026-04-07 — Cierre de Fase 2 ### Fase 0 — Sincronización ✅ From 9f00624f4011c008dfb9e80348fa4d585bbeda69 Mon Sep 17 00:00:00 2001 From: OpenCodeMCP-BetaTest Date: Wed, 8 Apr 2026 18:08:46 +0200 Subject: [PATCH 12/14] fix: to-float solo para waveform-chart, no para todos los indicadores MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit El `to-float` genérico antes del switch de tipos rompía indicadores string, cluster y booleanos cuyo valor ya era del tipo correcto. La conversión se mueve dentro del bloque waveform-chart exclusivamente, donde sí se necesita un float, con fallback a 0.0 si falla el parse. Fixes: str-indicator + unbundle → "cannot MAKE/TO float!" Co-Authored-By: Claude Sonnet 4.6 --- src/qtorres.red | 20 +++++++++----------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/src/qtorres.red b/src/qtorres.red index b6d40de..e5b7eaa 100644 --- a/src/qtorres.red +++ b/src/qtorres.red @@ -109,13 +109,12 @@ btn-run: make face! [ foreach item model/front-panel [ if item/name = n/name [ unless none? result-val [ - ; Asegurar que el valor es numérico - if string? result-val [result-val: to-float result-val] - ; Waveform Chart: acumular valor en buffer + ; Waveform Chart: acumular valor en buffer (necesita float) if item/type = 'waveform-chart [ - ; Inicializar buffer si es none + wv: either string? result-val [attempt [to-float result-val]] [result-val] + if none? wv [wv: 0.0] if none? item/value [item/value: copy []] - append item/value result-val + append item/value wv ; Limitar buffer a history-size (default 1024) history-size: any [select item/config 'history-size 1024] if (length? item/value) > history-size [ @@ -127,7 +126,7 @@ btn-run: make face! [ if item/type = 'waveform-graph [ item/value: copy result-val ] - ; Otros indicadores: valor simple + ; Otros indicadores: valor tal cual (string, number, boolean…) if not find [waveform-chart waveform-graph] item/type [ item/value: result-val ] @@ -143,13 +142,12 @@ btn-run: make face! [ foreach item model/front-panel [ if item/name = n/name [ unless none? result-val [ - ; Asegurar que el valor es numérico - if string? result-val [result-val: to-float result-val] - ; Waveform Chart desde estructura + ; Waveform Chart desde estructura (necesita float) if item/type = 'waveform-chart [ - ; Inicializar buffer si es none + wv: either string? result-val [attempt [to-float result-val]] [result-val] + if none? wv [wv: 0.0] if none? item/value [item/value: copy []] - append item/value result-val + append item/value wv history-size: any [select item/config 'history-size 1024] if (length? item/value) > history-size [ item/value: copy/part skip item/value ((length? item/value) - history-size) history-size From 9ad9f91f3bccfdd8978d1da1ac3ff72e94e7429f Mon Sep 17 00:00:00 2001 From: OpenCodeMCP-BetaTest Date: Wed, 8 Apr 2026 18:15:34 +0200 Subject: [PATCH 13/14] =?UTF-8?q?fix:=20suprimir=20prints=20de=20indicador?= =?UTF-8?q?es=20en=20ejecuci=C3=B3n=20UI=20(runner=20+=20btn-run)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit compile-body ahora tiene refinement /with-prints — los prints de indicadores solo se generan para el .qvi standalone (compile-diagram/with-prints). El runner en memoria (runner.red, qtorres.red btn-run) no produce salida por consola al ejecutar el diagrama desde la UI. Co-Authored-By: Claude Sonnet 4.6 --- src/compiler/compiler.red | 33 ++++++++++++++++++--------------- 1 file changed, 18 insertions(+), 15 deletions(-) diff --git a/src/compiler/compiler.red b/src/compiler/compiler.red index e037483..540c932 100644 --- a/src/compiler/compiler.red +++ b/src/compiler/compiler.red @@ -832,7 +832,8 @@ emit-cluster-indicator-headless: func [ ] compile-body: func [ - diagram [object!] + diagram [object!] + /with-prints ; añade print por indicador — solo para ejecución standalone (red-cli .qvi) /local sorted code item bdef ][ sorted: build-sorted-items diagram @@ -855,19 +856,21 @@ compile-body: func [ ] ] - ; Prints para modo headless — un print por indicador conectado - foreach item sorted [ - bdef: find-block item/type - if none? bdef [continue] - if bdef/category = 'output [ - if all [in diagram 'wires block? diagram/wires] [ - foreach w diagram/wires [ - if w/to-node = item/id [ - src: find-node-by-id diagram/nodes w/from-node - if src [ - src-var: port-var src to-word w/from-port - lbl: either all [item/label object? item/label] [item/label/text] [any [item/name ""]] - append code compose [print rejoin [(lbl) ": " form (src-var)]] + ; Prints para modo standalone (red-cli .qvi) — solo con /with-prints + if with-prints [ + foreach item sorted [ + bdef: find-block item/type + if none? bdef [continue] + if bdef/category = 'output [ + if all [in diagram 'wires block? diagram/wires] [ + foreach w diagram/wires [ + if w/to-node = item/id [ + src: find-node-by-id diagram/nodes w/from-node + if src [ + src-var: port-var src to-word w/from-port + lbl: either all [item/label object? item/label] [item/label/text] [any [item/name ""]] + append code compose [print rejoin [(lbl) ": " form (src-var)]] + ] ] ] ] @@ -895,7 +898,7 @@ compile-diagram: func [ /local sorted headless run-body ui-layout item node bdef face-n cfg-val w src src-var bindings ][ sorted: build-sorted-items diagram - headless: compile-body diagram + headless: compile-body/with-prints diagram ; ── Cuerpo del botón Run (modo UI) ──────────────────────── run-body: copy [] From 9533a266e9cc62ee37612db0227775a6f6ba1ff8 Mon Sep 17 00:00:00 2001 From: OpenCodeMCP-BetaTest Date: Thu, 9 Apr 2026 23:19:48 +0200 Subject: [PATCH 14/14] =?UTF-8?q?chore:=20versi=C3=B3n=200.2.0,=20limpieza?= =?UTF-8?q?=20de=20ficheros=20temporales?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Version: 0.0.1 → 0.2.0 en qtorres.red (Fase 2 completa) - README.md: badge de versión y estado actualizado - Eliminados 9 .bak/.bak2, 6 .qvi temporales, binarios y dirs de prueba Co-Authored-By: Claude Sonnet 4.6 --- README.md | 8 ++- findings.md | 149 ++++++++++++++++++++++++++++++++++++------------ src/qtorres.red | 2 +- 3 files changed, 121 insertions(+), 38 deletions(-) diff --git a/README.md b/README.md index 974c619..a490c00 100644 --- a/README.md +++ b/README.md @@ -1,5 +1,7 @@ # QTorres +> **v0.2.0** — Fase 2 completada (tipos, estructuras de control, waveform) + **LabVIEW open source construido sobre Red-Lang.** Si sabes programar en LabVIEW, sabes programar en QTorres. @@ -52,7 +54,11 @@ La estructura de ficheros replica las convenciones de LabVIEW. Donde LabVIEW gua ## Estado -**En desarrollo inicial.** El proyecto está en fase de diseño y prototipado. +**v0.2.0** — Alpha en desarrollo activo. + +- Fase 0 (spike) y Fase 1 (pipeline end-to-end): completadas +- Fase 2 (tipos de datos y estructuras de control): completada — 40 bloques, 462 tests +- Fase 3 (Sub-VIs y extensibilidad): próxima ## Estructura del proyecto diff --git a/findings.md b/findings.md index 124380b..8566802 100644 --- a/findings.md +++ b/findings.md @@ -1,6 +1,110 @@ -# Findings — Issue #13: Waveform Chart y Graph +# Findings — Transición Fase 2 -## Investigación LabVIEW (2026-04-03) +## Bug #54 — Cluster no persiste campos + +**Issue:** https://github.com/anlaco/QTorres/issues/54 + +**Síntomas:** +1. Al añadir campos a cluster-control en el editor → puertos no aparecen en BD +2. Al cerrar y reabrir el editor → campos desaparecen (no persisten) +3. Cluster-indicator no permite añadir ningún elemento + +**Componentes sospechosos:** +- `src/ui/diagram/canvas.red` — editor de cluster, render de puertos +- `src/ui/panel/panel.red` — gestión de cluster-indicator + +**Estado:** Pendiente de investigación con Task explore agent. + +--- + +## Auditoría Fase 2 (2026-04-03) + +**Documento:** `docs/auditoria-fase-2.md` (generado por qwen3-coder:480b) + +**Veredicto:** 🟢 Verde funcional, 🟡 refactor bloqueante para Fase 3 + +**Hallazgos críticos:** +- panel.red (1255 líneas) tiene responsabilidades de compilación y serialización +- canvas.red (2557 líneas) demasiado grande — riesgo pérdida contexto +- Ciclo canvas↔panel impide testing aislado +- Abstracciones faltantes: `find-node-by-id` (ya implementado en #56), `set-config` + +--- + +## Protecciones QA pendientes + +Extraídas de plan QA antiguo, estado desconocido: + +**QA-018:** Prohibir múltiples wires al mismo puerto entrada (Regla absoluta #6) +- Ubicación: `make-wire` en canvas.red o model.red + +**QA-024:** Fix `fp-default-label` + asignación label en `open-edit-dialog` +- Ubicación: panel.red + +**QA-029:** `save-panel-to-diagram` debe guardar `item/value`, no `item/default` +- Ubicación: panel.red +- Impacto: Round-trip incorrecto FP → qvi-diagram → FP + +--- + +## Estado de Issues Fase 2 + +**Bugs abiertos:** +- #54 (cluster) — CRÍTICO bloqueante +- #48 (bundle/unbundle altura) — menor +- #49 (string auto-update) — menor, posible GTK +- #50 (headless no imprime) — menor +- #51 (nodos apilados) — menor + +**Features pendientes:** +- #16 (Case Structure) — ¿completado? Verificar +- #13 (Waveform) — ✅ completado en #55 +- #12 (Cluster) — ✅ completado en #52, pero #54 es regresión +- #28 (FP standalone) — decisión pendiente: ¿Fase 2 o 3? + +--- + +## Arquitectura actual + +**Líneas de código (2026-04-07):** +- canvas.red: 2557 +- panel.red: 1255 +- compiler.red: 891 +- file-io.red: 647 + +**Dependencias problemáticas:** +- canvas.red → panel.red: `render-fp-panel` +- panel.red → canvas.red: `render-bd`, `gen-node-id` +- panel.red → compiler.red: ❌ NO (panel compila solo) +- panel.red → file-io.red: ❌ NO (panel serializa solo) + +**Chain loading actual (qtorres.red):** +```red +#include %graph/model.red +#include %graph/blocks.red +#include %compiler/compiler.red +#include %io/file-io.red +#include %runner/runner.red +#include %ui/diagram/canvas.red +#include %ui/panel/panel.red +``` + +Orden crítico: canvas antes que panel (por dependencia circular). + +--- + +## Próximas investigaciones + +1. **Grep QA-018/024/029:** Verificar si ya están aplicadas en el código actual +2. **Task explore #54:** Flujo cluster-control editor → config/fields → render puertos +3. **Inventario canvas.red:** Agrupar funciones por categoría (render/eventos/dialogs) + +--- + +## Histórico — Issue #13 (Waveform, completado) + +
+Investigación LabVIEW (2026-04-03) ### Diferencia fundamental Chart vs Graph @@ -11,54 +115,27 @@ | **Input** | Acepta scalar O array | Requiere array | | **Uso** | Real-time, loops | Post-análisis | -### Comportamiento en loops - -En LabVIEW: -- **Chart dentro de loop**: Se actualiza en CADA iteración. El wire conecta un valor escalar. -- **Graph dentro de loop**: Se actualiza al FINAL. El wire usa auto-indexing para acumular valores en un array. - ### Default buffer size -LabVIEW usa 1024 puntos por defecto para el history buffer del Chart. - -### Dimensiones - -LabVIEW no documenta dimensiones fijas en pixels. El tamaño por defecto depende de la versión y resolución de pantalla. Para QTorres: -- Área de trazado: 200x160 px (razonable para ver señal) -- Con bordes: ~240x200 px total +LabVIEW usa 1024 puntos por defecto. ---- - -## Decisión de diseño para QTorres - -### Waveform Chart +### Decisión de diseño QTorres +**Waveform Chart:** ```red -; fp-item type: 'waveform-chart data-type: 'number config: [history-size 1024] value: [] ; buffer circular ``` -- Input: scalar (se añade al buffer) o array (se añade punto a punto) -- Buffer circular: cuando se llena, descarta el más antiguo -- Render: fondo negro, línea verde, escala automática - -### Waveform Graph - +**Waveform Graph:** ```red -; fp-item type: 'waveform-graph data-type: 'array -value: [] ; array completo a mostrar +value: [] ; array completo ``` -- Input: array obligatorio -- Render: fondo negro, línea verde, escala automática -- No tiene buffer interno - -### Wire colors +Wire colors: Chart naranja, Graph naranja doble borde (array). -- Chart input: naranja (numérico escalar) -- Graph input: naranja con borde doble (array numérico) \ No newline at end of file +
diff --git a/src/qtorres.red b/src/qtorres.red index e5b7eaa..4f54856 100644 --- a/src/qtorres.red +++ b/src/qtorres.red @@ -1,7 +1,7 @@ Red [ Title: "QTorres" Author: "QTorres contributors" - Version: 0.0.1 + Version: 0.2.0 Purpose: "Entorno de programación visual tipo LabVIEW sobre Red-Lang" Needs: 'View ]