diff --git a/src/Renderer/Common/CommonTypes.fs b/src/Renderer/Common/CommonTypes.fs index 8d67f5b56..057269dbf 100644 --- a/src/Renderer/Common/CommonTypes.fs +++ b/src/Renderer/Common/CommonTypes.fs @@ -3,7 +3,7 @@ *) module CommonTypes - open Fable.Core + open Fable.Core open Optics #if FABLE_COMPILER open Thoth.Json @@ -21,34 +21,34 @@ module CommonTypes } static member inline zero: XYPos = {X=0.; Y=0.} - + /// allowed tolerance when comparing positions with floating point errors for equality static member inline epsilon = 0.0000001 - + /// Add postions as vectors (overlaoded operator) static member inline ( + ) (left: XYPos, right: XYPos) = { X = left.X + right.X; Y = left.Y + right.Y } - + /// Subtract positions as vectors (overloaded operator) static member inline ( - ) (left: XYPos, right: XYPos) = { X = left.X - right.X; Y = left.Y - right.Y } - + /// Scale a position by a number (overloaded operator). static member inline ( * ) (pos: XYPos, scaleFactor: float) = { X = pos.X*scaleFactor; Y = pos.Y * scaleFactor } - - /// Compare positions as vectors. Comparison is approximate so + + /// Compare positions as vectors. Comparison is approximate so /// it will work even with floating point errors. New infix operator. static member inline ( =~ ) (left: XYPos, right: XYPos) = abs (left.X - right.X) <= XYPos.epsilon && abs (left.Y - right.Y) <= XYPos.epsilon - - let inline euclideanDistance (pos1: XYPos) (pos2:XYPos) = + + let inline euclideanDistance (pos1: XYPos) (pos2:XYPos) = let vec = pos1 - pos2 sqrt(vec.X**2 + vec.Y**2) - + /// example use of comparison operator: note that F# type inference will not work without at least /// one of the two operator arguments having a known XYPos type. - let private testXYPosComparison a (b:XYPos) = + let private testXYPosComparison a (b:XYPos) = a =~ b /// display XYPos as string nicely for debugging @@ -56,7 +56,7 @@ module CommonTypes if max (abs x) (abs y) > 20. then $"(%.0f{x},%.0f{y})" else - $"(%.2f{x},%.2f{y})" + $"(%.2f{x},%.2f{y})" //==========================================// @@ -84,7 +84,7 @@ module CommonTypes 6. For symbols port numbers determine the vertical order in which ports are displayed. 7. Thus when changing the order of number of I/Os on a custom component port numbers can be changed as long as port lists and port name lists are similarly re-ordered. - 8. In the simulation port numbers are not relevant for custom comps - connections match port names with the + 8. In the simulation port numbers are not relevant for custom comps - connections match port names with the sheet input or output component for the port 9. In the simulation port numbers matter for all other ports: the simulator defines operation based on them. 10.In model.Symbol ports are kept in a single global map, including port numbers. If port numbers are permuted on @@ -97,7 +97,7 @@ module CommonTypes /// A component I/O. /// /// Id (like any other Id) is a string generated with 32 random hex charactes, - /// so it is (practically) globally unique. These Ids are used + /// so it is (practically) globally unique. These Ids are used /// to uniquely refer to ports and components. They are generated via uuid(). /// /// PortNumber is used to identify which port is which on a component, contiguous from 0 @@ -108,13 +108,13 @@ module CommonTypes type Port = { Id : string // For example, an And would have input ports 0 and 1, and output port 0. - // If the port is used in a Connection record as Source or Target, the Number is None. + // If the port is used in a Connection record as Source or Target, the Number is None. PortNumber : int option - PortType : PortType + PortType : PortType HostId : string } - + type PortId = | PortId of string // NB - this.Text() is not currently used. @@ -132,8 +132,8 @@ module CommonTypes | Six -> "6px" | Seven -> "7px" | Eight -> "8px" - - + + /// Type to specify the origin of a custom component type CCForm = |User @@ -162,7 +162,7 @@ module CommonTypes type Memory = { // How many bits the address should have. // The memory will have 2^AddressWidth memory locations. - AddressWidth : int + AddressWidth : int // How wide each memory word should be, in bits. WordWidth : int // Data is a list of <2^AddressWidth> elements, where each element is a @@ -172,8 +172,8 @@ module CommonTypes Data : Map } - - type InitMemData = + + type InitMemData = | FromData // old method (from data field) | FromFile of string // FromFile fName => read a file fName.ram for data | ToFile of string // ToFile fName => write data to a file fName.ram @@ -187,22 +187,22 @@ module CommonTypes Init: InitMemData // How many bits the address should have. // The memory will have 2^AddressWidth memory locations. - AddressWidth : int + AddressWidth : int // How wide each memory word should be, in bits. WordWidth : int // Data is a list of <2^AddressWidth> elements, where each element is a // 64 bit integer. This makes words longer than 64 bits not supported. // This can be changed by using strings instead of int64, but that is way // less memory efficient. - Data : Map - } + Data : Map + } + - type ShiftComponentType = |LSL |LSR |ASR - + [] type GateComponentType = | And @@ -214,14 +214,14 @@ module CommonTypes /// Option of this qualifies NBitsXOr to allow many different components /// None => Xor - /// TODO to reduce technical debt: + /// TODO to reduce technical debt: /// Rename NbitsXor as NBitsCustom, put all the Nbits ops into this D.U. /// Change catalog entries for all NBits ops to use NBitsCustom, alter load to remain compatibility. type NBitsArithmetic = | Multiply //Divide uncomment or add new cases to implement additional N bit operations. (match warnings will show what must be added) //Modulo - + // Each case contains the data needed to define a digital component of given Type // Used to read .dgm files, which may contain legacy ComponentType D.U. cases no longer used // Any NEW case added here must also be added (with identical from) to JSONComponentType @@ -240,10 +240,10 @@ module CommonTypes | Not | Decode4 | GateN of GateType: GateComponentType * NumInputs: int | Mux2 | Mux4 | Mux8 | Demux2 | Demux4 | Demux8 - | NbitsAdder of BusWidth: int | NbitsAdderNoCin of BusWidth: int - | NbitsAdderNoCout of BusWidth: int | NbitsAdderNoCinCout of BusWidth: int + | NbitsAdder of BusWidth: int | NbitsAdderNoCin of BusWidth: int + | NbitsAdderNoCout of BusWidth: int | NbitsAdderNoCinCout of BusWidth: int | NbitsXor of BusWidth:int * ArithmeticOp: NBitsArithmetic option - | NbitsAnd of BusWidth: int + | NbitsAnd of BusWidth: int | NbitsNot of BusWidth: int | NbitsOr of BusWidth: int | NbitSpreader of BusWidth: int | Custom of CustomComponentType // schematic sheet used as component @@ -262,7 +262,7 @@ module CommonTypes // legacy cases to be deleted? | BusCompare of BusWidth: int * CompareValue: uint32 | Input of BusWidth: int - | Constant of Width: int * ConstValue: int64 + | Constant of Width: int * ConstValue: int64 @@ -273,12 +273,12 @@ module CommonTypes match cType with | GateN (_, n) when n = 2 -> IsBinaryGate | _ -> NotBinaryGate - + let inline isNegated gateType = match gateType with | Nand | Nor | Xnor -> true | And | Or | Xor -> false - + let (|IsGate|NoGate|) cType = match cType with | GateN _ -> IsGate @@ -296,7 +296,7 @@ module CommonTypes let (|Memory|_|) (typ:ComponentType) = match typ with - | RAM1 mem + | RAM1 mem | AsyncRAM1 mem | ROM1 mem | AsyncROM1 mem -> Some mem @@ -314,12 +314,12 @@ module CommonTypes // --------------- Types needed for symbol ---------------- // /// Represents the rotation of a symbol in degrees, Degree0 is the default symbol rotation. /// Angle is anticlockwise - + type Rotation = | Degree0 | Degree90 | Degree180 | Degree270 - + /// Stores the rotation and the flip of the symbol, flipped false by default type STransform = {Rotation: Rotation; flipped: bool} - + /// Represents the sides of a component type Edge = @@ -327,7 +327,7 @@ module CommonTypes | Bottom | Left | Right - + /// HLP23: AUTHOR dgs119 member this.Opposite = match this with @@ -338,7 +338,7 @@ module CommonTypes /// Holds possible directions to sort ports. /// HLP23: AUTHOR dgs119 - + type Direction = | Clockwise | AntiClockwise @@ -355,8 +355,18 @@ module CommonTypes W: float /// Height H: float - } - with member this.Centre() = this.TopLeft + {X=this.W/2.; Y=this.H/2.} + } + + with + member this.Centre() = this.TopLeft + {X=this.W/2.; Y=this.H/2.} + + /// TDC21: allowed tolerance when comparing positions with floating point errors for equality + /// define a static member BoundingBox for comparisons, to be used in D1 + static member inline epsilon = 0.0000001 + static member inline (=~)(left: BoundingBox, right: BoundingBox) = + (left.TopLeft =~ right.TopLeft) + && abs (left.W - right.W) <= BoundingBox.epsilon + && abs (left.H - right.H) <= BoundingBox.epsilon let topLeft_ = Lens.create (fun a -> a.TopLeft) (fun s a -> {a with TopLeft = s}) @@ -365,7 +375,7 @@ module CommonTypes type ScaleAdjustment = | Horizontal | Vertical - + type SymbolInfo = { LabelBoundingBox: BoundingBox option LabelRotation: Rotation option @@ -394,11 +404,11 @@ module CommonTypes Id : string Type : ComponentType /// All components have a label that may be empty: label is not unique - Label : string + Label : string // position on this list determines inputPortNumber - InputPorts : Port list + InputPorts : Port list /// position in this list determines OutputPortNumber - OutputPorts : Port list + OutputPorts : Port list X : float Y : float /// Height @@ -410,10 +420,10 @@ module CommonTypes SymbolInfo : SymbolInfo option } - with member this.getPort (PortId portId: PortId) = + with member this.getPort (PortId portId: PortId) = List.tryFind (fun (port:Port) -> port.Id = portId ) (this.InputPorts @ this.OutputPorts) - - + + let type_ = Lens.create (fun c -> c.Type) (fun n c -> {c with Type = n}) let inputPorts_ = Lens.create (fun c -> c.InputPorts) (fun n c -> {c with InputPorts = n}) let outputPorts_ = Lens.create (fun c -> c.OutputPorts) (fun n c -> {c with OutputPorts = n}) @@ -433,7 +443,7 @@ module CommonTypes /// F# data describing the contents of a single schematic sheet. type CanvasState = Component list * Connection list - + /// reduced version of CanvasState for electrical comparison, all geometry removed, components ordered type ReducedCanvasState = | ReducedCanvasState of CanvasState @@ -469,10 +479,10 @@ module CommonTypes | Not | And | Or | Xor | Nand | Nor | Xnor | Decode4 | GateN of GateType: GateComponentType * NumInputs: int | Mux2 | Mux4 | Mux8 | Demux2 | Demux4 | Demux8 - | NbitsAdder of BusWidth: int | NbitsAdderNoCin of BusWidth: int - | NbitsAdderNoCout of BusWidth: int | NbitsAdderNoCinCout of BusWidth: int + | NbitsAdder of BusWidth: int | NbitsAdderNoCin of BusWidth: int + | NbitsAdderNoCout of BusWidth: int | NbitsAdderNoCinCout of BusWidth: int | NbitsXor of BusWidth:int * ArithmeticOp: NBitsArithmetic option - | NbitsAnd of BusWidth: int + | NbitsAnd of BusWidth: int | NbitsNot of BusWidth: int | NbitsOr of BusWidth: int | NbitSpreader of BusWidth: int | Custom of CustomComponentType // schematic sheet used as component @@ -491,7 +501,7 @@ module CommonTypes //---------------Legacy cases not in the Issie ComponentType here-------------------// | BusCompare of BusWidth: int * CompareValue: uint32 | Input of BusWidth: int - | Constant of Width: int * ConstValue: int64 + | Constant of Width: int * ConstValue: int64 @@ -516,7 +526,7 @@ module CommonTypes /// The default transform unboxes the value which works when there is no chnage in the JS value /// representation let convertFromJSONComponent (comp: JSONComponent.Component) : Component = - let newType (ct: JSONComponent.ComponentType) : ComponentType = + let newType (ct: JSONComponent.ComponentType) : ComponentType = match ct with | JSONComponent.ComponentType.Input1 (a,b) -> Input1 (a,b) | JSONComponent.ComponentType.Output x -> Output x @@ -558,7 +568,7 @@ module CommonTypes | JSONComponent.ComponentType.DFF -> DFF | JSONComponent.ComponentType.DFFE -> DFFE | JSONComponent.ComponentType.Register x -> Register x - | JSONComponent.ComponentType.RegisterE x -> RegisterE x + | JSONComponent.ComponentType.RegisterE x -> RegisterE x | JSONComponent.ComponentType.Counter x -> Counter x | JSONComponent.ComponentType.CounterNoLoad x -> CounterNoLoad x | JSONComponent.ComponentType.CounterNoEnable x -> CounterNoEnable x @@ -679,20 +689,20 @@ module CommonTypes - - - + + + // This code is for VERY OLD circuits... let legacyTypesConvert (lComps, lConns) = let convertConnection (c:LegacyCanvas.LegacyConnection) : Connection = { - Id=c.Id; + Id=c.Id; Source=c.Source; Target=c.Target; - Vertices = + Vertices = c.Vertices - |> List.map (function + |> List.map (function | (x,y) when x >= 0. && y >= 0. -> (x,y,false) | (x,y) -> (abs x, abs y, true)) } @@ -709,7 +719,7 @@ module CommonTypes H = comp.H W = comp.W SymbolInfo = None - + } let comps = List.map convertComponent lComps let conns = List.map convertConnection lConns @@ -732,7 +742,7 @@ module CommonTypes /// The Text() method converts it to the correct HTML string /// Where speed matters the color must be added as a case in the match statement type HighLightColor = Red | Blue | Yellow | Green | Orange | Grey | White | Purple | DarkSlateGrey | Thistle | Brown |SkyBlue - with + with member this.Text() = // the match statement is used for performance match this with | Red -> "Red" @@ -745,8 +755,8 @@ module CommonTypes | DarkSlateGrey -> "darkslategrey" | Thistle -> "thistle" | c -> sprintf "%A" c - - + + // The next types are not strictly necessary, but help in understanding what is what. // Used consistently they provide type protection that greatly reduces coding errors @@ -769,7 +779,7 @@ module CommonTypes | invalid -> Decode.fail (sprintf "Invalid case name: %s" invalid)) /// Unique identifier for a fast component. - /// The list is the access path, a list of all the containing custom components + /// The list is the access path, a list of all the containing custom components /// from the top sheet of the simulation (root first) type FComponentId = ComponentId * ComponentId list @@ -854,7 +864,7 @@ module CommonTypes (*-----------------------------------------------------------------------------*) // Types used within waveform Simulation code, and for saved wavesim configuartion - + /// Uniquely identifies a wave by the component it comes from, and the port on which that /// wave is from. Two waves can be identical but have a different index (e.g. a wave with /// PortType Input must be driven by another wave of PortType Output). @@ -866,7 +876,7 @@ module CommonTypes } - + /// Info saved by Wave Sim. @@ -894,14 +904,14 @@ module CommonTypes /// Info regarding sheet saved in the .dgm file type SheetInfo = { - Form: CCForm option + Form: CCForm option Description: string option } (*--------------------------------------------------------------------------------------------------*) /// Static data describing a schematic sheet loaded as a custom component. - /// Every sheet is always identified with a file from which it is loaded/saved. + /// Every sheet is always identified with a file from which it is loaded/saved. /// Name is human readable (and is the filename - without extension) and identifies sheet. /// File path is the sheet directory and name (with extension). /// InputLabels, OutputLabels are the I/O connections. @@ -917,7 +927,7 @@ module CommonTypes /// File name without extension = sheet name Name: string /// When the component was last saved - TimeStamp: System.DateTime + TimeStamp: System.DateTime /// Complete file path, including name and dgm extension FilePath : string /// Info on WaveSim settings @@ -951,9 +961,9 @@ module CommonTypes | Some ldc, _ -> let (comps, _) = ldc.CanvasState List.exists (isClocked (ct.Name :: visitedSheets) ldcs) comps - - + + | DFF | DFFE | Register _ | RegisterE _ | RAM _ | ROM _ | Counter _ |CounterNoEnable _ | CounterNoLoad _ |CounterNoEnableLoad _ -> true @@ -974,20 +984,20 @@ module CommonTypes LoadedComponents : LoadedComponent list } - + let loadedComponents_ = Lens.create (fun a -> a.LoadedComponents) (fun s a -> {a with LoadedComponents = s}) - let openLoadedComponent_ = - Lens.create - (fun a -> List.find (fun lc -> lc.Name = a.OpenFileName) a.LoadedComponents) + let openLoadedComponent_ = + Lens.create + (fun a -> List.find (fun lc -> lc.Name = a.OpenFileName) a.LoadedComponents) (fun lc' a -> {a with LoadedComponents = List.map (fun lc -> if lc.Name = a.OpenFileName then lc' else lc) a.LoadedComponents}) let openFileName_ = Lens.create (fun a -> a.OpenFileName) (fun s a -> {a with OpenFileName = s}) - let loadedComponentOf_ (name:string) = - Lens.create - (fun a -> List.find (fun lc -> lc.Name = name) a.LoadedComponents) + let loadedComponentOf_ (name:string) = + Lens.create + (fun a -> List.find (fun lc -> lc.Name = name) a.LoadedComponents) (fun lc' a -> {a with LoadedComponents = List.map (fun lc -> if lc.Name = name then lc' else lc) a.LoadedComponents}) diff --git a/src/Renderer/DrawBlock/Sheet.fs b/src/Renderer/DrawBlock/Sheet.fs index 396b4b9d0..5ddd332d7 100644 --- a/src/Renderer/DrawBlock/Sheet.fs +++ b/src/Renderer/DrawBlock/Sheet.fs @@ -70,7 +70,7 @@ module Constants = CanvasBorder = 0.5 // minimum scrollable white space border as fraction of circuit size after ctrlW CanvasExtensionFraction = 0.1 // fraction of screen size used to extend canvas by when going off edge |} - + //---------------------------------------Derived constants----------------------------------------// @@ -148,13 +148,13 @@ module SheetInterface = dispatch <| (Wire (BusWireT.DeleteWiresWithPort delPorts)) dispatch <| (Wire (BusWireT.UpdateSymbolWires compId)) //this.DoBusWidthInference dispatch - + member this.ChangeCounterComp (dispatch: Dispatch) (compId: ComponentId) (newComp:ComponentType) = dispatch <| (Wire (BusWireT.Symbol (SymbolT.ChangeCounterComponent (compId,(this.GetComponentById compId), newComp) ) ) ) let delPorts = SymbolPortHelpers.findDeletedPorts this.Wire.Symbol compId (this.GetComponentById compId) newComp dispatch <| (Wire (BusWireT.DeleteWiresWithPort delPorts)) dispatch <| (Wire (BusWireT.UpdateSymbolWires compId)) - + /// Given a compId, update the ReversedInputs property of the Component specified by compId member this.ChangeReversedInputs (dispatch: Dispatch) (compId: ComponentId) = dispatch <| (Wire (BusWireT.Symbol (SymbolT.ChangeReversedInputs (compId) ) ) ) @@ -205,7 +205,7 @@ module SheetInterface = member this.ClearCanvas dispatch = dispatch <| ResetModel dispatch <| Wire BusWireT.ResetModel - dispatch <| Wire (BusWireT.Symbol (SymbolT.ResetModel ) ) + dispatch <| Wire (BusWireT.Symbol (SymbolT.ResetModel ) ) /// Returns a list of selected components member this.GetSelectedComponents = @@ -215,16 +215,16 @@ module SheetInterface = [SymbolUpdate.extractComponent this.Wire.Symbol compId] else []) - + /// Returns a list of selected connections member this.GetSelectedConnections = this.SelectedWires |> List.collect (fun connId -> if Map.containsKey connId this.Wire.Wires then [BusWire.extractConnection this.Wire connId] - else + else []) - + /// Returns a list of selected components and connections in the form of (Component list * Connection list) member this.GetSelectedCanvasState = this.GetSelectedComponents, this.GetSelectedConnections @@ -248,7 +248,7 @@ module SheetInterface = //-------------------------------------------------------------------------------------------------// - + //Calculates the symmetric difference of two lists, returning a list of the given type let symDiff lst1 lst2 = @@ -282,12 +282,12 @@ let centreOfScreen model : XYPos = /// returns true if pos is insoie boundingbox let insideBox (pos: XYPos) boundingBox = let {BoundingBox.TopLeft={X = xBox; Y=yBox}; H=hBox; W=wBox} = boundingBox - pos.X >= xBox && pos.X <= xBox + wBox && pos.Y >= yBox && pos.Y <= yBox + hBox + pos.X >= xBox && pos.X <= xBox + wBox && pos.Y >= yBox && pos.Y <= yBox + hBox /// Checks if pos is inside any of the bounding boxes of the components in boundingBoxes -let inline insideBoxMap - (boundingBoxes: Map) - (pos: XYPos) +let inline insideBoxMap + (boundingBoxes: Map) + (pos: XYPos) : CommonTypes.ComponentId Option = boundingBoxes |> Map.tryFindKey (fun k box -> insideBox pos box)// If there are multiple components overlapping (should not happen), return first one found @@ -303,24 +303,24 @@ let inline tryInsideLabelBox (model: Model) (pos: XYPos) = let inline tryInsideSymCorner (model: Model) (pos: XYPos) = let radius = 5.0 let margin = 2.5 - + let insideCircle (pos: XYPos) (circleLocation: XYPos) radius margin: bool = let distance = ((pos.X - circleLocation.X) ** 2.0 + (pos.Y - circleLocation.Y) ** 2.0) ** 0.5 distance <= radius + margin - let tryGetOppositeCorners corners= + let tryGetOppositeCorners corners= match corners with | [||] -> None // should never match - | _ -> + | _ -> Array.tryFindIndex (fun c -> insideCircle pos c radius margin) corners |> function | Some idx -> Some (corners[(idx + 2) % 4], idx) | None -> None Optic.get symbols_ model - |> Map.tryPick (fun (sId:ComponentId) (sym:SymbolT.Symbol) -> + |> Map.tryPick (fun (sId:ComponentId) (sym:SymbolT.Symbol) -> match sym.Component.Type with - | CommonTypes.Custom _ -> + | CommonTypes.Custom _ -> getCustomSymCorners sym |> (translatePoints sym.Pos) |> tryGetOppositeCorners @@ -362,7 +362,7 @@ let boxUnion (box:BoundingBox) (box':BoundingBox) = let boxPointUnion (box: BoundingBox) (point: XYPos) = let pBox = {TopLeft=point; W=0.;H=0.} boxUnion box pBox - + let symbolToBB (centresOnly: bool) (symbol:SymbolT.Symbol) = let co = symbol.Component let h,w = Symbol.getRotatedHAndW symbol @@ -380,7 +380,7 @@ let symbolToCentre (symbol:SymbolT.Symbol) = let wireToBB (wire:BusWireT.Wire) = let initBox = {TopLeft=wire.StartPos;W=0.;H=0.} (initBox,wire) - ||> BlockHelpers.foldOverNonZeroSegs (fun _ ePos box _ -> + ||> BlockHelpers.foldOverNonZeroSegs (fun _ ePos box _ -> boxPointUnion box ePos) @@ -395,7 +395,7 @@ let symbolBBUnion (centresOnly: bool) (symbols: SymbolT.Symbol list) :BoundingBo else boxUnion box (boxUnion (symbolToBB centresOnly sym) (sym.LabelBoundingBox))) |> Some - + /// Returns the smallest BB that contains all symbols, labels, and wire segments. @@ -416,7 +416,7 @@ let symbolWireBBUnion (model:Model) = | [] -> None | _ -> Some <| List.reduce boxUnion labelsBB let wireBB = - let wiresBBA = + let wiresBBA = model.Wire.Wires |> Helpers.mapValues |> Array.map wireToBB @@ -451,10 +451,10 @@ let getWindowParasToFitBox model (box: BoundingBox) = {|Scroll={X=xScroll; Y=yScroll}; MagToUse=magToUse|} let addBoxMargin (fractionalMargin:float) (absoluteMargin:float) (box: BoundingBox) = - let boxMargin = + let boxMargin = (max box.W box.H) * fractionalMargin - |> max absoluteMargin - + |> max absoluteMargin + { TopLeft = box.TopLeft - {X = boxMargin; Y = boxMargin} W = box.W + boxMargin*2. H = box.H + boxMargin*2. @@ -467,10 +467,10 @@ let addBoxMargin (fractionalMargin:float) (absoluteMargin:float) (box: BoundingB let ensureCanvasExtendsBeyondScreen model : Model = let boxParas = Constants.boxParameters let edge = getScreenEdgeCoords model - let box = + let box = symbolWireBBUnion model |> addBoxMargin boxParas.CanvasExtensionFraction boxParas.BoxMin - let quant = boxParas.CanvasExtensionFraction * min box.H box.W + let quant = boxParas.CanvasExtensionFraction * min box.H box.W let newSize = [box.H;box.W] |> List.map (fun x -> x + 4.*quant) @@ -483,9 +483,9 @@ let ensureCanvasExtendsBeyondScreen model : Model = if xIsOk && yIsOk then model else - let circuitMove = + let circuitMove = box - |> (fun bb -> + |> (fun bb -> let centre = bb.Centre() { X = if xIsOk then 0. else newSize/2.- centre.X @@ -500,16 +500,16 @@ let ensureCanvasExtendsBeyondScreen model : Model = | None,_-> () let posDelta :(XYPos -> XYPos) = ((+) circuitMove) let posScreenDelta :(XYPos -> XYPos) = ((+) (circuitMove*model.Zoom)) - model + model |> moveCircuit circuitMove - |> Optic.map screenScrollPos_ posDelta + |> Optic.map screenScrollPos_ posDelta |> Optic.set canvasSize_ newSize |> Optic.map screenScrollPos_ posScreenDelta |> Optic.map lastMousePos_ posDelta |> Optic.map lastMousePosForSnap_ posDelta |> Optic.map (scrollingLastMousePos_ >-> pos_) posDelta - - + + @@ -523,10 +523,10 @@ let fitCircuitToWindowParas (model:Model) = let boxParas = Constants.boxParameters let minBox = {TopLeft = {X=100.; Y=100.}; W=100.; H=100.} - let sBox = + let sBox = symbolWireBBUnion model |> addBoxMargin boxParas.BoxMarginFraction boxParas.BoxMin - let newCanvasSize = + let newCanvasSize = max sBox.W sBox.H |> ((*) (1. + 2. * boxParas.CanvasBorder)) |> max Constants.defaultCanvasSize @@ -537,7 +537,7 @@ let fitCircuitToWindowParas (model:Model) = {model with CanvasSize = newCanvasSize} |> moveCircuit offsetToCentreCircuit - let sBox = {sBox with TopLeft = sBox.TopLeft + offsetToCentreCircuit} + let sBox = {sBox with TopLeft = sBox.TopLeft + offsetToCentreCircuit} let paras = getWindowParasToFitBox model sBox {modelWithMovedCircuit with Zoom = paras.MagToUse @@ -550,9 +550,9 @@ let isBBoxAllVisible model (bb: BoundingBox) = let z = model.Zoom let lh,rh,top,bottom = edge.Left/z,edge.Right/z,edge.Top/z,edge.Bottom/z let bbs = standardiseBox bb - lh < bb.TopLeft.Y && - top < bb.TopLeft.X && - bb.TopLeft.Y+bb.H < bottom && + lh < bb.TopLeft.Y && + top < bb.TopLeft.X && + bb.TopLeft.Y+bb.H < bottom && bb.TopLeft.X+bb.W < rh /// could be made more efficient, since segments contain redundant info @@ -564,7 +564,7 @@ let getWireBBox (wire: BusWireT.Wire) = let newLeft = min state.TopLeft.X segEnd.X {TopLeft={X=newTop; Y=newLeft}; W=newRight-newLeft; H=newBottom-newTop } BlockHelpers.foldOverSegs updateBoundingBox {TopLeft = wire.StartPos; W=0; H=0;} wire - + let isAllVisible (model: Model)(conns: ConnectionId list) (comps: ComponentId list) = let wVisible = @@ -577,7 +577,7 @@ let isAllVisible (model: Model)(conns: ConnectionId list) (comps: ComponentId li let cVisible = comps |> List.collect (fun comp -> - if Map.containsKey comp model.Wire.Symbol.Symbols then + if Map.containsKey comp model.Wire.Symbol.Symbols then [Symbol.getBoundingBox model.Wire.Symbol comp] else []) @@ -586,7 +586,7 @@ let isAllVisible (model: Model)(conns: ConnectionId list) (comps: ComponentId li wVisible && cVisible - + /// Finds all components that touch a bounding box (which is usually the drag-to-select box) let findIntersectingComponents (model: Model) (box1: BoundingBox) = model.BoundingBoxes @@ -600,7 +600,7 @@ let posAdd (pos : XYPos) (a : float, b : float) : XYPos = /// Finds all components (that are stored in the Sheet model) near pos let findNearbyComponents (model: Model) (pos: XYPos) (range: float) = // Larger Increments -> More Efficient. But can miss small components then. - List.allPairs [-range .. 10.0 .. range] [-range .. 10.0 .. range] + List.allPairs [-range .. 10.0 .. range] [-range .. 10.0 .. range] |> List.map ((fun x -> posAdd pos x) >> insideBoxMap model.BoundingBoxes) |> List.collect ((function | Some x -> [x] | _ -> [])) @@ -614,7 +614,7 @@ let mouseOnPort portList (pos: XYPos) (margin: float) = distance <= radius + margin // + 2.5 margin to make it a bit easier to click on, maybe it's due to the stroke width? - match List.tryFind (fun (_, portLocation) -> insidePortCircle pos portLocation) portList with + match List.tryFind (fun (_, portLocation) -> insidePortCircle pos portLocation) portList with | Some (portId, portLocation) -> Some (portId, portLocation) | None -> None diff --git a/src/Renderer/DrawBlock/SheetDisplay.fs b/src/Renderer/DrawBlock/SheetDisplay.fs index 4a1bed68f..4d8b909d6 100644 --- a/src/Renderer/DrawBlock/SheetDisplay.fs +++ b/src/Renderer/DrawBlock/SheetDisplay.fs @@ -8,9 +8,10 @@ open DrawHelpers open DrawModelType open DrawModelType.SheetT open Optics -open Operators +open Operators open Sheet open SheetSnap +open JSHelpers module Constants = let KeyPressPersistTimeMs = 1000. @@ -39,12 +40,12 @@ let getDrawBlockPos (ev: Types.MouseEvent) (headerHeight: float) (sheetModel:Mod /// This function zooms an SVG canvas by transforming its content and altering its size. /// Currently the zoom expands based on top left corner. -let displaySvgWithZoom - (model: Model) - (headerHeight: float) - (style: CSSProp list) - (svgReact: ReactElement List) - (dispatch: Dispatch) +let displaySvgWithZoom + (model: Model) + (headerHeight: float) + (style: CSSProp list) + (svgReact: ReactElement List) + (dispatch: Dispatch) : ReactElement= let zoom = model.Zoom @@ -65,7 +66,7 @@ let displaySvgWithZoom /// Is the mouse button currently down? let mDown (ev:Types.MouseEvent) = ev.buttons <> 0. - + /// Dispatch a MouseMsg (compensated for zoom) let mouseOp op (ev:Types.MouseEvent) = @@ -90,7 +91,7 @@ let displaySvgWithZoom let cursorText = model.CursorType.Text() let firstView = viewIsAfterUpdateScroll viewIsAfterUpdateScroll <- false - div [ + div [ HTMLAttr.Id "Canvas" Key cursorText // force cursor change to be rendered Style (CSSProp.Cursor cursorText :: style) @@ -125,11 +126,11 @@ let displaySvgWithZoom ] /// View function, displays symbols / wires and possibly also a grid / drag-to-select box / connecting ports line / snap-to-grid visualisation -let view - (model:Model) - (headerHeight: float) - (style: CSSProp list) - (dispatch : Msg -> unit) +let view + (model:Model) + (headerHeight: float) + (style: CSSProp list) + (dispatch : Msg -> unit) : ReactElement = let start = TimeHelpers.getTimeMs() let wDispatch wMsg = dispatch (Wire wMsg) @@ -173,18 +174,53 @@ let view let {BoundingBox.TopLeft = {X=fX; Y=fY}; H=fH; W=fW} = model.DragToSelectBox let polygonPoints = $"{fX},{fY} {fX+fW},{fY} {fX+fW},{fY+fH} {fX},{fY+fH}" let selectionBox = {Stroke = "Black"; StrokeWidth = "0.1px"; Fill = "Blue"; FillOpacity = 0.05 } + let selectionBoxDev = {Stroke = "Black"; StrokeWidth = "0.1px"; Fill = "Red"; FillOpacity = 0.05 } + + /// Makes a polygon ReactElement for a developer mode dragToSelectBox, with added text info + /// points are to be given as a correctly formatted SVGAttr.Points string + let makePolygonDevMode (points: string) (polygonParameters: Polygon) (debugOutput: string) = + let debugOutputLength = debugOutput.Length + let firstPoint = points.Split ' ' |> Array.head |> fun s -> s.Split ',' + let textX, textY = firstPoint.[0], firstPoint.[1] + g [] [ + polygon [ + SVGAttr.Points points + SVGAttr.Stroke polygonParameters.Stroke + SVGAttr.StrokeWidth polygonParameters.StrokeWidth + SVGAttr.Fill polygonParameters.Fill + SVGAttr.FillOpacity polygonParameters.FillOpacity + ] [] + rect [ + SVGAttr.X textX + SVGAttr.Y (string(float textY - 14.)) + SVGAttr.Width (string (debugOutput.Length * 6)) + SVGAttr.Height "14" + SVGAttr.Fill "white" + ] [] + text [ + SVGAttr.X (string(float textX + 5.)) + SVGAttr.Y textY + SVGAttr.FontSize "10" + SVGAttr.Dy "-3" + ] [ str debugOutput ] + ] + if debugLevel > 0 && model.DeveloperModeTabActive then + let fw_shortened = fW.ToString("F1") + let fh_shortened = fH.ToString("F1") + let debugOutput = $"{fw_shortened} x {fh_shortened}" + makePolygonDevMode polygonPoints selectionBoxDev debugOutput + else + makePolygon polygonPoints selectionBox - makePolygon polygonPoints selectionBox - - // rotating the default horizontal scaleButton icon to match the diagonal of the scalingBox + // rotating the default horizontal scaleButton icon to match the diagonal of the scalingBox let rotateScaleButtonPoint boxW boxH point = let diagonal = sqrt(boxW**2.0+boxH**2.0) let cosTheta = - (boxW / diagonal) - let sinTheta = boxH / diagonal + let sinTheta = boxH / diagonal let {XYPos.X = x; XYPos.Y = y} = point {X = x*cosTheta - y*sinTheta; Y = (y*cosTheta + x*sinTheta)} - + /// Draws an annotation on the SVG canvas - equivalent of drawSymbol but used for visual objects /// with no underlying electrical component. /// annotations have an Annotation field and a dummy Component used to provide expected H,W @@ -192,25 +228,25 @@ let view let transform = symbol.STransform let outlineColour, strokeWidth = "black", "1.0" let H,W = symbol.Component.H, symbol.Component.W - let createAnyPath (startingPoint: XYPos) (pathAttr: string) colour strokeWidth outlineColour = + let createAnyPath (startingPoint: XYPos) (pathAttr: string) colour strokeWidth outlineColour = [makeAnyPath startingPoint pathAttr {defaultPath with Fill = colour; StrokeWidth = strokeWidth; Stroke = outlineColour}] match symbol.Annotation with - | None -> + | None -> failwithf "Should not be getting Annotation = None for drawing scalingBox buttons " | Some a -> match a with | SymbolT.ScaleButton -> - let shapePointsPre = - [ (4.5, -2.); + let shapePointsPre = + [ (4.5, -2.); (4.5, -5.); (10.5, 0.); (4.5, 5.); (4.5, 2.); - (-4.5, 2.); + (-4.5, 2.); (-4.5, 5.); (-10.5, 0.); (-4.5, -5.); (-4.5, -2.); (4.5, -2.) ] |> List.map (fun (x,y) -> rotateScaleButtonPoint boxW boxH {X=x;Y=y}) - let shapePoints = + let shapePoints = [1..10] |> List.fold (fun lst x -> (shapePointsPre[x] - shapePointsPre[x-1])::lst) [shapePointsPre[0]] |> List.rev @@ -218,13 +254,13 @@ let view let arrowHeadTopRight = ((makeLineAttr (shapePoints[1].X) shapePoints[1].Y)) + ((makeLineAttr (shapePoints[2].X) shapePoints[2].Y)) + ((makeLineAttr (shapePoints[3].X) shapePoints[3].Y)) + ((makeLineAttr (shapePoints[4].X) shapePoints[4].Y))+ ((makeLineAttr (shapePoints[5].X) shapePoints[5].Y)) let arrowHeadBottomLeft = ((makeLineAttr (shapePoints[6].X) shapePoints[6].Y)) + ((makeLineAttr (shapePoints[7].X) shapePoints[7].Y)) + ((makeLineAttr (shapePoints[8].X) shapePoints[8].Y)) + ((makeLineAttr (shapePoints[9].X) shapePoints[9].Y))+ ((makeLineAttr (shapePoints[10].X) shapePoints[10].Y)) (createAnyPath (symbol.Pos+shapePoints[0])(arrowHeadTopRight+arrowHeadBottomLeft) "grey" strokeWidth outlineColour) - + | SymbolT.RotateButton _ -> - + //chooses the shape of curvy components so flip and rotations are correct //HLP23: Author Ismagilov - let adjustCurvyPoints (points:XYPos[] List) = - match transform.Rotation,transform.flipped with + let adjustCurvyPoints (points:XYPos[] List) = + match transform.Rotation,transform.flipped with | Degree0, false -> points[0] | Degree0, true -> points[2] | Degree90, _-> points[1] @@ -239,24 +275,24 @@ let view [| (2.*W/3., 7.*H/9.); (0.,(-H/9.)); (W/4.,(H/6.));(-W/4.,H/6.);(0, -H/9.);(0.001, -W/2.); (0.001, W/2.);(W/4., 0);(0, H/9.);(-W/4., 0);(0, 7.*W/18.);(0, -7.*W/18.) |] - ] + ] |> List.map (Array.map (fun (x,y) -> {X=x;Y=y})) |> adjustCurvyPoints let arrowHead = ((makeLineAttr (curvyShape[1].X) curvyShape[1].Y)) + ((makeLineAttr (curvyShape[2].X) curvyShape[2].Y)) + ((makeLineAttr (curvyShape[3].X) curvyShape[3].Y)) + ((makeLineAttr (curvyShape[4].X) curvyShape[4].Y)) let arcAttr1 = makePartArcAttr (W/2.)(curvyShape[5].Y) (curvyShape[5].X) (curvyShape[6].Y) (curvyShape[6].X) - let touchUp = ((makeLineAttr (curvyShape[7].X) curvyShape[7].Y)) + ((makeLineAttr (curvyShape[8].X) curvyShape[8].Y)) + ((makeLineAttr (curvyShape[9].X) curvyShape[9].Y)) + let touchUp = ((makeLineAttr (curvyShape[7].X) curvyShape[7].Y)) + ((makeLineAttr (curvyShape[8].X) curvyShape[8].Y)) + ((makeLineAttr (curvyShape[9].X) curvyShape[9].Y)) let arcAttr2 = makePartArcAttr (7.*W/18.)(curvyShape[10].Y) (curvyShape[10].X) (curvyShape[11].Y) (curvyShape[11].X) - (createAnyPath (symbol.Pos + curvyShape[0]) (arrowHead+arcAttr1+touchUp+arcAttr2) "grey" strokeWidth outlineColour) + (createAnyPath (symbol.Pos + curvyShape[0]) (arrowHead+arcAttr1+touchUp+arcAttr2) "grey" strokeWidth outlineColour) - let scalingBox = + let scalingBox = match model.ScalingBox with | None -> [makeAnyPath {X=0;Y=0} (makeLineAttr 0.0 0.0) defaultPath] @ [makeCircle 0.0 0.0 {defaultCircle with R=0.0}] - | _ -> + | _ -> let {BoundingBox.TopLeft = {X=fX; Y=fY}; H=fH; W=fW} = model.ScalingBox.Value.ScalingBoxBound - [makeAnyPath {X=fX+50.0+fW;Y=(fY-46.5)} ((makeLineAttr 0.0 (fH+96.5))+(makeLineAttr -(fW+100.0) 0)+(makeLineAttr 0.0 (-(fH)-100.0))+(makeLineAttr (fW+96.5) 0.0)) {defaultPath with StrokeDashArray="4,4"}] + [makeAnyPath {X=fX+50.0+fW;Y=(fY-46.5)} ((makeLineAttr 0.0 (fH+96.5))+(makeLineAttr -(fW+100.0) 0)+(makeLineAttr 0.0 (-(fH)-100.0))+(makeLineAttr (fW+96.5) 0.0)) {defaultPath with StrokeDashArray="4,4"}] @ drawAnnotation model.ScalingBox.Value.RotateDeg270Button (fH+100.) (fW+100.) @ drawAnnotation model.ScalingBox.Value.RotateDeg90Button (fH+100.) (fW+100.) @ drawAnnotation model.ScalingBox.Value.ScaleButton (fH+100.) (fW+100.) @@ -291,12 +327,12 @@ let view displaySvgWithZoom model headerHeight style ( displayElements @ snaps @ scalingBox) dispatch | (MovingSymbols),_ -> displaySvgWithZoom model headerHeight style ( displayElements @ snaps @ scalingBox) dispatch - | MovingWire _,_ -> + | MovingWire _,_ -> displaySvgWithZoom model headerHeight style (displayElements @ snaps) dispatch - | Scaling, _ -> + | Scaling, _ -> // printfn "displaying scalingBox when action = scaling" displaySvgWithZoom model headerHeight style ( displayElements @ scalingBox ) dispatch - | _ , Some _ -> + | _ , Some _ -> // printfn "displaying scalingBox when action is not scaling" displaySvgWithZoom model headerHeight style ( displayElements @ scalingBox ) dispatch diff --git a/src/Renderer/DrawBlock/SheetUpdate.fs b/src/Renderer/DrawBlock/SheetUpdate.fs index de58f5a51..bb0c0f565 100644 --- a/src/Renderer/DrawBlock/SheetUpdate.fs +++ b/src/Renderer/DrawBlock/SheetUpdate.fs @@ -33,7 +33,7 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd ) = + let postUpdateChecks (model:Model, cmd:Cmd ) = // Executed every update so performance is important. // Since normally state will be correct it is only necessary to make the checking // fast. @@ -43,10 +43,10 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd (fun sMap -> (model,sMap) - ||> Map.fold (fun model sId sym -> - if Map.containsKey sId model.BoundingBoxes + ||> Map.fold (fun model sId sym -> + if Map.containsKey sId model.BoundingBoxes && sym.Pos = model.BoundingBoxes[sId].TopLeft then - model + model else Optic.set boundingBoxes_ (Symbol.getBoundingBoxes sModel) model)) |> ensureCanvasExtendsBeyondScreen @@ -55,11 +55,11 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd (fun currentmodel -> {currentmodel with TmpModel = Some currentmodel}) match msg with - | Wire (BusWireT.Symbol SymbolT.Msg.UpdateBoundingBoxes) -> + | Wire (BusWireT.Symbol SymbolT.Msg.UpdateBoundingBoxes) -> // Symbol cannot directly send a message to Sheet box Sheet message type is out of scape. This // is used so that a symbol message can be intercepted by sheet and used there. model, Cmd.batch [ - sheetCmd UpdateBoundingBoxes; + sheetCmd UpdateBoundingBoxes; ] | Wire wMsg -> let wModel, (wCmd) = BusWireUpdate.update wMsg issieModel @@ -131,7 +131,7 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd List.truncate (max 0 (inputLst.Length - 1)) - + match List.length redoList with |n when n < 500 -> model_in :: redoList | _ -> model_in :: (removeLast redoList) @@ -154,12 +154,12 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd fitCircuitToScreenUpdate model - + | PortMovementStart -> match model.Action with - | Idle -> - {model with CtrlKeyDown = true}, - Cmd.batch + | Idle -> + {model with CtrlKeyDown = true}, + Cmd.batch [ symbolCmd (SymbolT.ShowCustomOnlyPorts model.NearbyComponents) symbolCmd (SymbolT.ShowCustomCorners model.NearbyComponents) @@ -168,9 +168,9 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd match model.Action with - | Idle -> - {model with CtrlKeyDown = false}, - Cmd.batch + | Idle -> + {model with CtrlKeyDown = false}, + Cmd.batch [ symbolCmd (SymbolT.ShowPorts model.NearbyComponents) symbolCmd (SymbolT.HideCustomCorners model.NearbyComponents) @@ -182,7 +182,7 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd model, Cmd.none | Down -> mDownUpdate model mMsg - | Drag -> + | Drag -> //printfn "running sheet.update" mDragUpdate model mMsg | Up -> mUpUpdate model mMsg @@ -198,10 +198,10 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd match Map.containsKey compId model.BoundingBoxes with - | true -> - {model with + | true -> + {model with BoundingBoxes = model.BoundingBoxes.Add (compId, (Symbol.getBoundingBox model.Wire.Symbol compId))} - |> Optic.map symbols_ (Map.change compId (Option.map Symbol.calcLabelBoundingBox)) + |> Optic.map symbols_ (Map.change compId (Option.map Symbol.calcLabelBoundingBox)) , Cmd.none | false -> model, Cmd.none @@ -209,7 +209,7 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd= 0, canvasDiv with | _, None | false, _ -> model - | true, Some el -> + | true, Some el -> recentProgrammaticScrollPos |> List.exists (fun recent -> euclideanDistance recent pos < 0.001 ) |> function | true -> model @@ -218,7 +218,7 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd //printfn "%s" $"{scrollSequence}: Model -> canvas {scrollPos.X},{scrollPos.Y}" let scrollDif = scrollPos - model.ScreenScrollPos * (1. / model.Zoom) @@ -237,9 +237,9 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd @@ -247,11 +247,11 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd let oldScreenCentre = getVisibleScreenCentre model - { model with Zoom = min Constants.maxMagnification (model.Zoom*Constants.zoomIncrement) }, + { model with Zoom = min Constants.maxMagnification (model.Zoom*Constants.zoomIncrement) }, sheetCmd (KeepZoomCentered oldScreenCentre) // Zooming out decreases the model.Zoom. The centre of the screen will stay centred (if possible) @@ -274,7 +274,7 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd @@ -355,9 +355,9 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd - mMoveUpdate { model with AutomaticScrolling = true } {defaultMsg with Op = Move} + mMoveUpdate { model with AutomaticScrolling = true } {defaultMsg with Op = Move} | MovingSymbols | ConnectingInput _ | ConnectingOutput _ | Selecting -> - mDragUpdate { model with AutomaticScrolling = true } {defaultMsg with Op = Drag} + mDragUpdate { model with AutomaticScrolling = true } {defaultMsg with Op = Drag} | _ -> { model with AutomaticScrolling = true }, Cmd.none let notAutomaticScrolling msg = match msg with | ModelType.Sheet CheckAutomaticScrolling -> false | _ -> true @@ -376,26 +376,26 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd rotateSelectedLabelsClockwise model - + | Rotate rotation -> //Replaced normal rotation, so individual and block rotation is correct //HLP23: Author Ismagilov // printfn "Running Rotate %A" rotation - let rotmodel = + let rotmodel = {model with Wire = {model.Wire with Symbol = (RotateScale.rotateBlock model.SelectedComponents model.Wire.Symbol rotation)} TmpModel = Some model UndoList = appendUndoList model.UndoList model} let newModel = {rotmodel with BoundingBoxes = Symbol.getBoundingBoxes rotmodel.Wire.Symbol} - + let errorComponents = newModel.SelectedComponents |> List.filter (fun sId -> not (notIntersectingComponents newModel newModel.BoundingBoxes[sId] sId)) printfn $"ErrorComponents={errorComponents}" - + match errorComponents with - | [] -> + | [] -> {newModel with ErrorComponents = errorComponents; Action = Idle}, Cmd.batch [ symbolCmd (SymbolT.ErrorSymbols (errorComponents,newModel.SelectedComponents,false)) @@ -408,11 +408,11 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd - let flipmodel = + let flipmodel = {model with Wire = {model.Wire with Symbol = (RotateScale.flipBlock model.SelectedComponents model.Wire.Symbol orientation)} TmpModel = Some model UndoList = appendUndoList model.UndoList model} @@ -425,9 +425,9 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd + | [] -> newModel.Action | _ -> DragAndDrop @@ -457,7 +457,7 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd let wires = model.Wire.Wires |> Map.toList |> List.map fst model, @@ -465,12 +465,12 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd match compType with - | IsGate -> + | IsGate -> { model with Action = (InitialisedCreateComponent (ldcs, compType, lbl)); UndoList = appendUndoList model.UndoList model; @@ -538,9 +538,9 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd List.contains cId cIds |> not) model.PrevWireSelection else List.append cIds model.PrevWireSelection - {model with SelectedWires = newWires}, + {model with SelectedWires = newWires}, Cmd.batch [ - sheetCmd (ColourSelection([], newWires, HighLightColor.SkyBlue)); + sheetCmd (ColourSelection([], newWires, HighLightColor.SkyBlue)); wireCmd (BusWireT.SelectWires newWires)] | SetSpinner isOn -> if isOn then {model with CursorType = Spinner}, Cmd.none @@ -564,38 +564,38 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd Option.map (fun c -> c.pid)) if not model.Compiling then model, Cmd.none - else + else let cwd = getCWD () - let include_path = + let include_path = match JSHelpers.debugLevel <> 0 with |true -> cwd+"/static/hdl" - |false -> cwd+"/resources/static/hdl" - + |false -> cwd+"/resources/static/hdl" + printfn "include_path: %s" include_path let pcf,deviceType,devicePackage,USBdevice = match model.DebugDevice, profile with - |Some "IceStick",Verilog.Release -> + |Some "IceStick",Verilog.Release -> $"{include_path}/icestick.pcf", "--hx1k", "tq144", "i:0x0403:0x6010" - - |Some "IceStick",Verilog.Debug -> + + |Some "IceStick",Verilog.Debug -> $"{include_path}/icestick_debug.pcf", "--hx1k", "tq144", "i:0x0403:0x6010" - - |Some "IssieStick-v0.1", Verilog.Release -> + + |Some "IssieStick-v0.1", Verilog.Release -> $"{include_path}/issiestick-0.1.pcf", "--hx4k", "tq144", "i:0x0403:0xed1c" - - |Some "IssieStick-v0.1", Verilog.Debug -> + + |Some "IssieStick-v0.1", Verilog.Debug -> $"{include_path}/issiestick-0.1_debug.pcf", "--hx4k", "tq144", "i:0x0403:0xed1c" - - |Some "IssieStick-v1.0", Verilog.Release -> + + |Some "IssieStick-v1.0", Verilog.Release -> $"{include_path}/issiestick-1.0.pcf", "--hx8k", "bg121", "i:0x0403:0xed1c" - - |Some "IssieStick-v1.0", Verilog.Debug -> + + |Some "IssieStick-v1.0", Verilog.Debug -> $"{include_path}/issiestick-1.0_debug.pcf", "--hx8k", "bg121", "i:0x0403:0xed1c" - + |_,_ -> failwithf "Undefined device used in compilation!" - - let (prog, args) = + + let (prog, args) = // make build dir match stage with | Synthesis -> "yosys", ["-p"; $"read_verilog -I{include_path} {path}/{name}.v; synth_ice40 -flatten -json {path}/build/{name}.json"]//"sh", ["-c"; "sleep 4 && echo 'finished synthesis'"] @@ -667,7 +667,7 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd Option.map (fun c -> c.pid)) let correctPid = model.CompilationProcess - |> Option.map (fun child -> child.pid = pid) + |> Option.map (fun child -> child.pid = pid) |> Option.defaultValue false let tick stage = @@ -716,69 +716,69 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd //printfn "mappings: %A" model.DebugMappings let remainder = (Array.length model.DebugMappings) % 8 - let viewerNo = + let viewerNo = match remainder with - |0 -> (Array.length model.DebugMappings) / 8 + |0 -> (Array.length model.DebugMappings) / 8 |_ -> (Array.length model.DebugMappings) / 8 + 1 - + model, sheetCmd (DebugStepAndRead viewerNo) | DebugStepAndRead n -> //printfn "reading" - + let readSingleStep viewers dispatch = - + Async.StartImmediate(async { let exit_code = ref 0 try let keepGoing = ref true let r = stepAndReadAllViewers(viewers) - r.``then``(fun v -> + r.``then``(fun v -> v - |> Array.iteri (fun i reading -> + |> Array.iteri (fun i reading -> //printfn "got : %s" (reading[0].ToString() + reading[1].ToString()) dispatch <| ModelType.Sheet (OnDebugRead (hextoInt (reading[0].ToString() + reading[1].ToString()),i)) - ) + ) ) |> ignore - + keepGoing.Value <- false finally () }) - + model, Cmd.ofSub (readSingleStep n) | DebugRead n -> //printfn "reading" - + let readSingleStep viewers dispatch = - + Async.StartImmediate(async { let exit_code = ref 0 try let keepGoing = ref true let r = readAllViewers(viewers) - r.``then``(fun v -> + r.``then``(fun v -> v - |> Array.iteri (fun i reading -> + |> Array.iteri (fun i reading -> //printfn "got : %s" (reading[0].ToString() + reading[1].ToString()) dispatch <| ModelType.Sheet (OnDebugRead (hextoInt (reading[0].ToString() + reading[1].ToString()),i)) - ) + ) ) |> ignore - + keepGoing.Value <- false finally () }) - + model, Cmd.ofSub (readSingleStep n) - | DebugConnect -> + | DebugConnect -> let remainder = (Array.length model.DebugMappings) % 8 - let viewerNo = + let viewerNo = match remainder with - |0 -> (Array.length model.DebugMappings) / 8 + |0 -> (Array.length model.DebugMappings) / 8 |_ -> (Array.length model.DebugMappings) / 8 + 1 - + let connectAndRead viewers dispatch = Async.StartImmediate(async { let exit_code = ref 0 @@ -786,10 +786,10 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd + c.``then``(fun v -> dispatch <| ModelType.Sheet (DebugRead viewers) )|> ignore - + keepGoing.Value <- false finally () @@ -821,7 +821,7 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd @@ -829,16 +829,16 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd (Array.length model.DebugMappings) / 8 + | 0 -> (Array.length model.DebugMappings) / 8 | _ -> (Array.length model.DebugMappings) / 8 + 1 - - + + {model with DebugState = Paused}, sheetCmd (DebugStepAndRead viewerNo) | SetDebugDevice device -> {model with DebugDevice = Some device}, Cmd.none - + | ToggleSnapToNet -> model, (wireCmd BusWireT.ToggleSnapToNet) @@ -847,7 +847,7 @@ let update (msg : Msg) (issieModel : ModelType.Model): ModelType.Model*Cmd {model with Wire = wModel}, Cmd.none - + | ToggleNet _ | DoNothing | _ -> model, Cmd.none |> postUpdateChecks // |> Optic.map fst_ postUpdateChecks @@ -907,6 +907,7 @@ let init () = DebugMappings = [||] DebugDevice = None ScalingBox = None + DeveloperModeTabActive = false }, (Cmd.none: Cmd) diff --git a/src/Renderer/DrawBlock/SymbolUpdate.fs b/src/Renderer/DrawBlock/SymbolUpdate.fs index 42dc8afb7..cd1916443 100644 --- a/src/Renderer/DrawBlock/SymbolUpdate.fs +++ b/src/Renderer/DrawBlock/SymbolUpdate.fs @@ -22,13 +22,13 @@ let rec extractIOPrefix (str : string) (charLst: char list) = let len = String.length str match len with |0 -> "",-1 - |_ -> + |_ -> match str[len-1] with - |c when Char.IsNumber(Convert.ToChar(c)) -> + |c when Char.IsNumber(Convert.ToChar(c)) -> let newstr = str.Remove(len-1) extractIOPrefix newstr ([str[len-1]]@charLst) - | _ -> - let strNo = + | _ -> + let strNo = match List.length charLst with |0 -> "" |_ -> ("", charLst) ||> List.fold (fun s v -> s+(string v)) @@ -44,7 +44,7 @@ let generateIOLabel (model: Model) (compType: ComponentType) (name:string) : str |> List.collect (fun sym -> match sym.Component.Type with |IOLabel | NotConnected -> [] - |_ -> + |_ -> let baseName,no = extractIOPrefix sym.Component.Label [] if baseName = newCompBaseName then [no] @@ -56,16 +56,16 @@ let generateIOLabel (model: Model) (compType: ComponentType) (name:string) : str if newCompNo = -1 then name+"1" else name - |lst -> + |lst -> let max = List.max existingNumbers if List.exists (fun x -> x=newCompNo) lst then newCompBaseName + (string (max+1)) - else + else name /// Returns the number of the component label (i.e. the number 1 from IN1 or ADDER16.1) -let getLabelNumber (str : string) = +let getLabelNumber (str : string) = let index = Regex.Match(str, @"\d+$") match index with | null -> 0 @@ -77,11 +77,11 @@ let generateLabelNumber listSymbols compType = let compType = symbol.Component.Type (getPrefix target) = (getPrefix compType) - let samePrefixLst = + let samePrefixLst = listSymbols |> List.filter (samePrefix compType) - if List.isEmpty samePrefixLst then 1 + if List.isEmpty samePrefixLst then 1 else samePrefixLst |> List.map (fun sym -> getLabelNumber sym.Component.Label) |> List.max @@ -90,14 +90,14 @@ let generateLabelNumber listSymbols compType = /// Generates the label for a component type let generateLabel (model: Model) (compType: ComponentType) : string = - let listSymbols = List.map snd (Map.toList model.Symbols) + let listSymbols = List.map snd (Map.toList model.Symbols) let prefix = getPrefix compType match compType with | IOLabel | BusSelection _ | NotConnected -> prefix | _ -> prefix + (generateLabelNumber listSymbols compType) let generateCopiedLabel (model: Model) (oldSymbol:Symbol) (compType: ComponentType) : string = - let listSymbols = List.map snd (Map.toList model.Symbols) + let listSymbols = List.map snd (Map.toList model.Symbols) let prefix = getPrefix compType match compType with | IOLabel | NotConnected -> oldSymbol.Component.Label @@ -110,28 +110,28 @@ let generateCopiedLabel (model: Model) (oldSymbol:Symbol) (compType: ComponentTy let initCopiedPorts (oldSymbol:Symbol) (newComp: Component): PortMaps = let inPortIds = List.map (fun (p:Port) -> p.Id) newComp.InputPorts let outPortIds = List.map (fun (p:Port) -> p.Id) newComp.OutputPorts - let oldInPortIds = + let oldInPortIds = List.map (fun (p:Port) -> p.Id) oldSymbol.Component.InputPorts let oldOutPortIds = List.map (fun (p:Port) -> p.Id) oldSymbol.Component.OutputPorts - let equivPortIds = + let equivPortIds = List.zip oldInPortIds inPortIds @ List.zip oldOutPortIds outPortIds |> Map.ofList - let portOrientation = + let portOrientation = (Map.empty,oldSymbol.PortMaps.Orientation) - ||> Map.fold + ||> Map.fold (fun currMap oldPortId edge -> Map.add equivPortIds[oldPortId] edge currMap) - let emptyPortOrder = + let emptyPortOrder = (Map.empty, [Edge.Top; Edge.Bottom; Edge.Left; Edge.Right]) ||> List.fold (fun currMap edge -> Map.add edge [] currMap) let portOrder = (emptyPortOrder, oldSymbol.PortMaps.Order) - ||> Map.fold - (fun currMap side oldList -> + ||> Map.fold + (fun currMap side oldList -> let newList = ([], oldList) - ||> List.fold + ||> List.fold (fun currList oldPortId -> currList @ [equivPortIds[oldPortId]]) Map.add side newList currMap) @@ -142,49 +142,49 @@ let initCopiedPorts (oldSymbol:Symbol) (newComp: Component): PortMaps = /// Currently drag-and-drop. /// Pastes a list of symbols into the model and returns the new model and the id of the pasted modules. let pasteSymbols (model: Model) (wireMap:Map) (newBasePos: XYPos) : (Model * ComponentId list) = - + let oldSymbolsList = model.CopiedSymbols |> Map.toList |> List.map snd - + let addNewSymbol (basePos: XYPos) ((currSymbolModel, pastedIdsList) : Model * ComponentId List) (oldSymbol: Symbol): Model * ComponentId List = - + let newId = JSHelpers.uuid() let newPos = oldSymbol.Pos - basePos + newBasePos let compType = oldSymbol.Component.Type - let newLabel = + let newLabel = match compType with | IOLabel -> //Wire label is special case: if the driver of the wire label is not included -> keep same name //else generate new label (cannot have wire labels with same name driven by 2 different components) let inPortId = oldSymbol.Component.InputPorts[0].Id let wires = wireMap |> Map.toList |> List.map snd - let targetWire = + let targetWire = wires - |> List.tryFind (fun w -> w.InputPort = (InputPortId inPortId)) + |> List.tryFind (fun w -> w.InputPort = (InputPortId inPortId)) match targetWire with - |Some w -> + |Some w -> let origSymPortId = match w.OutputPort with |OutputPortId id -> id - let origSym = - oldSymbolsList + let origSym = + oldSymbolsList |> List.tryFind (fun s -> (List.exists (fun (p:Port) -> p.Id = origSymPortId) s.Component.OutputPorts)) - - match origSym with + + match origSym with |Some s -> generateIOLabel { model with Symbols = currSymbolModel.Symbols} compType oldSymbol.Component.Label |None -> generateCopiedLabel { model with Symbols = currSymbolModel.Symbols} oldSymbol compType |None -> generateCopiedLabel { model with Symbols = currSymbolModel.Symbols} oldSymbol compType - | _ -> + | _ -> compType |> generateCopiedLabel { model with Symbols = currSymbolModel.Symbols} oldSymbol let newComp = makeComponent newPos compType newId newLabel - + let newSymbol = { oldSymbol with Id = ComponentId newId Component = newComp Pos = newPos - Appearance = + Appearance = {oldSymbol.Appearance with ShowPorts = ShowNone // ShowOutputPorts = false @@ -194,22 +194,22 @@ let pasteSymbols (model: Model) (wireMap:Map Symbol.autoScaleHAndW - - + + let newSymbolMap = currSymbolModel.Symbols.Add (ComponentId newId, newSymbol) let newPorts = addToPortModel currSymbolModel newSymbol let newModel = { currSymbolModel with Symbols = newSymbolMap; Ports = newPorts } let newPastedIdsList = pastedIdsList @ [ newSymbol.Id ] newModel, newPastedIdsList - + match oldSymbolsList with | [] -> model, [] - | _ -> + | _ -> let baseSymbol = List.minBy (fun sym -> sym.Pos.X) oldSymbolsList let basePos = baseSymbol.Pos + { X = (float baseSymbol.Component.W) / 2.0; Y = (float baseSymbol.Component.H) / 2.0 } ((model, []), oldSymbolsList) ||> List.fold (addNewSymbol basePos) - + /// Returns the hostId of the port in model let getPortHostId (model: Model) portId = model.Ports[portId].HostId @@ -218,7 +218,7 @@ let getPortHostId (model: Model) portId = /// Returns Some if there is exactly one element in copiedIds matching the target AND if there is an element in pastedIds at that same index, None otherwise. let tryGetPastedEl copiedIds pastedIds target = // try to look for a symbol in copiedIds, get the index and return pastedIds[index] - let indexedTarget = + let indexedTarget = copiedIds |> List.indexed |> List.filter (fun (_, id) -> id = target) @@ -229,7 +229,7 @@ let tryGetPastedEl copiedIds pastedIds target = /// Returns a tuple of the list of input ports of a given input symbol, and list of output ports of a given output symbol let getPortIds (input: Symbol) (output: Symbol) : (string list * string list)= - let inPortIds = + let inPortIds = input.Component.InputPorts |> List.map (fun port -> port.Id) let outPortIds = @@ -256,31 +256,31 @@ let getEquivalentCopiedPorts (model: Model) (copiedIds) (pastedIds) (InputPortId let findEquivalentPorts compId1 compId2 = let copiedComponent = model.CopiedSymbols[compId1].Component let pastedComponent = model.Symbols[compId2].Component // TODO: These can be different for an output gate for some reason. - + let tryFindEquivalentPort (copiedPorts: Port list) (pastedPorts: Port list) targetPort = if copiedPorts.Length = 0 || pastedPorts.Length = 0 then None else match List.tryFindIndex ( fun (port: Port) -> port.Id = targetPort ) copiedPorts with - | Some portIndex -> + | Some portIndex -> Some pastedPorts[portIndex].Id // Get the equivalent port in pastedPorts. Assumes ports at the same index are the same (should be the case unless copy pasting went wrong). | _ -> None - + let pastedInputPortId = tryFindEquivalentPort copiedComponent.InputPorts pastedComponent.InputPorts copiedInputPort let pastedOutputPortId = tryFindEquivalentPort copiedComponent.OutputPorts pastedComponent.OutputPorts copiedOutputPort - + pastedInputPortId, pastedOutputPortId - + let foundPastedPorts = List.zip copiedIds pastedIds |> List.map (fun (compId1, compId2) -> findEquivalentPorts compId1 compId2) - + let foundPastedInputPort = List.collect (function | Some a, _ -> [a] | _ -> []) foundPastedPorts let foundPastedOutputPort = List.collect (function | _, Some b -> [b] | _ -> []) foundPastedPorts - - match foundPastedInputPort, foundPastedOutputPort with - | [pastedInputPort], [pastedOutputPort] -> Some (pastedInputPort, pastedOutputPort) + + match foundPastedInputPort, foundPastedOutputPort with + | [pastedInputPort], [pastedOutputPort] -> Some (pastedInputPort, pastedOutputPort) | _ -> None // If either of source or target component of the wire was not copied then we discard the wire /// Creates and adds a symbol into model, returns the updated model and the component id @@ -296,20 +296,20 @@ let addSymbol (ldcs: LoadedComponent list) (model: Model) pos compType lbl = /// Given a model and a list of component ids deletes the specified components from the model and returns the updated model let inline deleteSymbols (model: Model) compIds = - let newSymbols = + let newSymbols = (model.Symbols, compIds) - ||> List.fold (fun prevModel sId -> Map.remove sId prevModel) + ||> List.fold (fun prevModel sId -> Map.remove sId prevModel) { model with Symbols = newSymbols } /// Given a model and a list of component ids copies the specified components and returns the updated model let copySymbols (model: Model) compIds = - let copiedSymbols = + let copiedSymbols = model.Symbols - |> Map.filter (fun compId _ -> List.contains compId compIds) + |> Map.filter (fun compId _ -> List.contains compId compIds) { model with CopiedSymbols = copiedSymbols } - + /// Move a symbol by the amount specified by move let private moveSymbol (move: XYPos) (sym: Symbol) : Symbol = {sym with @@ -326,9 +326,9 @@ let private moveSymbol (move: XYPos) (sym: Symbol) : Symbol = /// Given a model, a component id list and an offset, moves the components by offset and returns the updated model let moveSymbols (model:Model) (compList: ComponentId list) (offset: XYPos)= - let resetSymbols = + let resetSymbols = model.Symbols - |> Map.map (fun _ sym -> { sym with Moving = false}) + |> Map.map (fun _ sym -> { sym with Moving = false}) let moveSymbolInMap prevSymbols sId = prevSymbols @@ -343,7 +343,7 @@ let moveSymbols (model:Model) (compList: ComponentId list) (offset: XYPos)= /// Given a model and a component id list, sets the color of the sepcified symbols to red and every other symbol's color to gray let inline symbolsHaveError model compList = - let resetSymbols = + let resetSymbols = model.Symbols |> Map.map (fun _ sym -> set (appearance_ >-> colour_) (getSymbolColour sym.Component.Type sym.IsClocked model.Theme) sym) @@ -352,55 +352,55 @@ let inline symbolsHaveError model compList = let newSymbols = (resetSymbols, compList) - ||> List.fold setSymColorToRed + ||> List.fold setSymColorToRed { model with Symbols = newSymbols } /// Given a model and a component id list, it updates the specified symbols' colour to green with max opacity, and every other symbols' colour to gray let inline selectSymbols model compList = - let resetSymbols = + let resetSymbols = model.Symbols - |> Map.map (fun _ sym -> + |> Map.map (fun _ sym -> sym |> map appearance_ ( - set colour_ (getSymbolColour sym.Component.Type sym.IsClocked model.Theme) >> - set opacity_ 1.0 + set colour_ (getSymbolColour sym.Component.Type sym.IsClocked model.Theme) >> + set opacity_ 1.0 ) |> set moving_ false ) let updateSymbolColour prevSymbols sId = Map.add sId (set (appearance_ >-> colour_) "lightgreen" (set moving_ true resetSymbols[sId])) prevSymbols - + let newSymbols = (resetSymbols, compList) - ||> List.fold updateSymbolColour + ||> List.fold updateSymbolColour { model with Symbols = newSymbols} /// Given a model, an error component list, a selected component id list, it updates the selected symbols' color to green if they are not selected, and changes the symbols with errors to red. It returns the updated model. let inline errorSymbols model (errorCompList,selectCompList,isDragAndDrop) = - let resetSymbols = + let resetSymbols = model.Symbols - |> Map.map + |> Map.map (fun _ sym -> Optic.map appearance_ (set colour_ (getSymbolColour sym.Component.Type sym.IsClocked model.Theme) >> set opacity_ 1.0) sym) - + let updateSymbolStyle prevSymbols sId = - if not isDragAndDrop then + if not isDragAndDrop then Map.add sId (set (appearance_ >-> colour_) "lightgreen" resetSymbols[sId]) prevSymbols - else + else Map.add sId (set (appearance_ >-> opacity_) 0.2 resetSymbols[sId]) prevSymbols let selectSymbols = (resetSymbols, selectCompList) - ||> List.fold updateSymbolStyle + ||> List.fold updateSymbolStyle let setSymColourToRed prevSymbols sId = Map.add sId (set (appearance_ >-> colour_) "Red" resetSymbols[sId]) prevSymbols - let newSymbols = + let newSymbols = (selectSymbols, errorCompList) ||> List.fold setSymColourToRed - + { model with Symbols = newSymbols } /// Given a model, a symbol id and a new label changes the label of the symbol to the new label and returns the updated model. @@ -410,7 +410,7 @@ let inline changeLabel (model: Model) sId newLabel= model // do nothing if symbol has been deleted | Some oldSym -> let newComp = {oldSym.Component with Label = newLabel} - let newSym = + let newSym = { oldSym with Component = newComp; LabelHasDefaultPos = true} |> calcLabelBoundingBox set (symbolOf_ sId) newSym model @@ -419,7 +419,7 @@ let inline changeLabel (model: Model) sId newLabel= /// Given a model, a component id list and a color, updates the color of the specified symbols and returns the updated model. let inline colorSymbols (model: Model) compList colour = let changeSymColour (prevSymbols: Map) (sId: ComponentId) = - let newSymbol = set (appearance_ >-> colour_) (string colour) prevSymbols[sId] + let newSymbol = set (appearance_ >-> colour_) (string colour) prevSymbols[sId] prevSymbols |> Map.add sId newSymbol let newSymbols = @@ -431,11 +431,11 @@ let inline colorSymbols (model: Model) compList colour = /// Initialises a symbol containing the component and returns the updated symbol map containing the new symbol let createSymbolRecord ldcs theme comp = let clocked = isClocked [] ldcs comp - let portMaps = + let portMaps = match comp.SymbolInfo with - | None -> + | None -> initPortOrientation comp - | Some info -> + | Some info -> {Order=info.PortOrder; Orientation=info.PortOrientation} let xyPos = {X = comp.X; Y = comp.Y} let (h,w) = @@ -451,7 +451,7 @@ let createSymbolRecord ldcs theme comp = match comp.SymbolInfo with | Some {LabelBoundingBox=Some info} -> false, info | _ -> true, {TopLeft=xyPos; W=0.;H=0.} - { + { Pos = xyPos CentrePos = {X = 0.; Y = 0} OffsetFromBBCentre = {X = 0.; Y = 0.} @@ -476,7 +476,7 @@ let createSymbolRecord ldcs theme comp = STransform = getSTransformWithDefault comp.SymbolInfo ReversedInputPorts = match comp.SymbolInfo with |Some si -> si.ReversedInputPorts |_ -> None PortMaps = portMaps - + MovingPort = None IsClocked = clocked MovingPortTarget = None @@ -518,7 +518,7 @@ let createAnnotation (theme: ThemeType) (a:Annotation) (pos: XYPos) = (14.0,14.0) ||> createDummyComponent pos |> createSymbolRecord [] theme - |> (fun sym -> {sym with Annotation= Some a; Moving = true}) + |> (fun sym -> {sym with Annotation= Some a; Moving = true}) /// Given a model and a list of components, it creates and adds the symbols containing /// the specified components and returns the updated model. @@ -527,7 +527,7 @@ let loadComponents loadedComponents model comps= (model.Symbols, comps) ||> List.fold (createSymbol loadedComponents model.Theme) let addPortsToModel currModel _ sym = { currModel with Ports = addToPortModel currModel sym } - + let newModel = ( model, symbolMap ) ||> Map.fold addPortsToModel { newModel with Symbols = symbolMap } @@ -549,40 +549,40 @@ let inline writeMemoryLine model (compId, addr, value) = let newSym = (set (component_ >-> type_) newCompType symbol) set (symbolOf_ compId) newSym model - + /// Given a model, a component Id and a memory component type, updates the type of the component to the specified memory type and returns the updated model. let inline writeMemoryType model compId memory = let symbol = model.Symbols[compId] - let comp = symbol.Component - + let comp = symbol.Component + let newCompType = match comp.Type with | RAM1 _ | AsyncRAM1 _ | ROM1 _ | AsyncROM1 _ -> memory - | _ -> + | _ -> printfn $"Warning: improper use of WriteMemoryType on {comp} ignored" comp.Type - + let newComp = { comp with Type = newCompType } - + set (symbolOf_ compId >-> component_) newComp model /// Given a model, a component Id and a memory component type, updates the type of the component to the specified memory and returns the updated model. let inline updateMemory model compId updateFn = let symbol = model.Symbols[compId] - let comp = symbol.Component - + let comp = symbol.Component + let newCompType = match comp.Type with | RAM1 m -> RAM1 (updateFn m) | ROM1 m -> ROM1 (updateFn m) | AsyncROM1 m -> AsyncROM1 (updateFn m) | AsyncRAM1 m -> AsyncRAM1 (updateFn m) - | _ -> + | _ -> printfn $"Warning: improper use of WriteMemoryType on {comp} ignored" comp.Type - + let newComp = { comp with Type = newCompType } - + Optic.set (symbolOf_ compId >-> component_) newComp model @@ -613,12 +613,12 @@ let inline updateSymbol (updateFn: Symbol->Symbol) (compId: ComponentId) (model: { model with Symbols = model.Symbols.Add (compId, updateFn model.Symbols[compId]) } let inline transformSymbols transform model compList = - let transformedSymbols = + let transformedSymbols = compList |> List.map (fun id-> transform model.Symbols[id]) - let newSymbolMap = - (model.Symbols, transformedSymbols) + let newSymbolMap = + (model.Symbols, transformedSymbols) ||> List.fold (fun currSymMap sym -> currSymMap |> Map.add sym.Id sym) - + set symbols_ newSymbolMap model @@ -629,7 +629,7 @@ let inline transformSymbols transform model compList = /// Move a symbol's label by the amount specified by move let private moveLabel (move: XYPos) (sym: Symbol) : Symbol = {sym with - LabelBoundingBox = + LabelBoundingBox = {sym.LabelBoundingBox with TopLeft = sym.LabelBoundingBox.TopLeft + move} LabelHasDefaultPos = false } @@ -652,12 +652,12 @@ let getLayoutInfoFromSymbol symbol = { STransform = symbol.STransform ReversedInputPorts = symbol.ReversedInputPorts PortOrientation = symbol.PortMaps.Orientation - PortOrder = symbol.PortMaps.Order + PortOrder = symbol.PortMaps.Order LabelRotation = symbol.LabelRotation - LabelBoundingBox = - if symbol.LabelHasDefaultPos then - None - else + LabelBoundingBox = + if symbol.LabelHasDefaultPos then + None + else Some symbol.LabelBoundingBox HScale = symbol.HScale VScale = symbol.VScale @@ -679,24 +679,24 @@ let checkSymbolIntegrity (sym: Symbol) = let ChangeGate (compId, gateType, numInputs) model = let newSymbol = changeGateComponent model compId gateType numInputs let newPorts = addToPortModel model newSymbol - let newModel = {model with Ports = newPorts} + let newModel = {model with Ports = newPorts} (replaceSymbol newModel newSymbol compId) - + let ChangeMergeN (compId, numInputs) model = let newSymbol = changeMergeNComponent model compId numInputs let newPorts = addToPortModel model newSymbol - let newModel = {model with Ports = newPorts} + let newModel = {model with Ports = newPorts} (replaceSymbol newModel newSymbol compId) let ChangeSplitN (compId, numInputs, widths, lsbs) model = let newSymbol = changeSplitNComponent model compId numInputs widths lsbs let newPorts = addToPortModel model newSymbol - let newModel = {model with Ports = newPorts} + let newModel = {model with Ports = newPorts} (replaceSymbol newModel newSymbol compId) /// Update function which displays symbols -let update (msg : Msg) (model : Model): Model*Cmd<'a> = +let update (msg : Msg) (model : Model): Model*Cmd<'a> = match msg with | UpdateBoundingBoxes -> // message used to update symbol bounding boxes in sheet. @@ -720,14 +720,14 @@ let update (msg : Msg) (model : Model): Model*Cmd<'a> = (showAllOutputPorts model), Cmd.none | DeleteAllPorts -> - (deleteAllPorts model), Cmd.none + (deleteAllPorts model), Cmd.none | ShowPorts compList -> (showPorts model compList), Cmd.none | ShowCustomOnlyPorts compList -> (showCustomPorts model compList), Cmd.none - | MoveSymbols (compList, move) -> + | MoveSymbols (compList, move) -> (moveSymbols model compList move), Cmd.none | MoveLabel (compId, move) -> @@ -738,11 +738,11 @@ let update (msg : Msg) (model : Model): Model*Cmd<'a> = | SelectSymbols compList -> // printfn "update msg: selectsymbols" - (selectSymbols model compList), Cmd.none + (selectSymbols model compList), Cmd.none + + | ErrorSymbols (errorCompList,selectCompList,isDragAndDrop) -> + (errorSymbols model (errorCompList,selectCompList,isDragAndDrop)), Cmd.none - | ErrorSymbols (errorCompList,selectCompList,isDragAndDrop) -> - (errorSymbols model (errorCompList,selectCompList,isDragAndDrop)), Cmd.none - | MouseMsg _ -> model, Cmd.none // allow unused mouse messages | ChangeLabel (sId, newLabel) -> @@ -751,26 +751,26 @@ let update (msg : Msg) (model : Model): Model*Cmd<'a> = | PasteSymbols compList -> let newSymbols = (model.Symbols, compList) - ||> List.fold (fun prevSymbols sId -> - Map.add sId (set (appearance_ >-> opacity_) 0.4 model.Symbols[sId]) prevSymbols) - { model with Symbols = newSymbols }, Cmd.none - - | ColorSymbols (compList, colour) -> - (colorSymbols model compList colour), Cmd.none - + ||> List.fold (fun prevSymbols sId -> + Map.add sId (set (appearance_ >-> opacity_) 0.4 model.Symbols[sId]) prevSymbols) + { model with Symbols = newSymbols }, Cmd.none + + | ColorSymbols (compList, colour) -> + (colorSymbols model compList colour), Cmd.none + | ChangeNumberOfBits (compId, newBits) -> let newsymbol = changeNumberOfBitsf model compId newBits (replaceSymbol model newsymbol compId), Cmd.none - + | ChangeScale (compId,newScale,whichScale) -> let symbol = Map.find compId model.Symbols - let newSymbol = + let newSymbol = match whichScale with |Horizontal -> {symbol with HScale=Some newScale} |Vertical -> {symbol with VScale=Some newScale} (replaceSymbol model newSymbol compId), Cmd.none - | ChangeLsb (compId, newLsb) -> + | ChangeLsb (compId, newLsb) -> let newsymbol = changeLsbf model compId newLsb (replaceSymbol model newsymbol compId), Cmd.none @@ -784,57 +784,57 @@ let update (msg : Msg) (model : Model): Model*Cmd<'a> = | ChangeAdderComponent (compId, oldComp, newComp) -> let newSymbol = changeAdderComponent model compId oldComp newComp let newPorts = addToPortModel model newSymbol - let newModel = {model with Ports = newPorts} + let newModel = {model with Ports = newPorts} (replaceSymbol newModel newSymbol compId), Cmd.none | ChangeCounterComponent (compId, oldComp, newComp) -> let newSymbol = changeCounterComponent model compId oldComp newComp let newPorts = addToPortModel model newSymbol - let newModel = {model with Ports = newPorts} + let newModel = {model with Ports = newPorts} (replaceSymbol newModel newSymbol compId), Cmd.none - | ChangeConstant (compId, newVal, newText) -> + | ChangeConstant (compId, newVal, newText) -> let newsymbol = changeConstantf model compId newVal newText (replaceSymbol model newsymbol compId), Cmd.none - - | ChangeBusCompare (compId, newVal, newText) -> + + | ChangeBusCompare (compId, newVal, newText) -> let newsymbol = changeBusComparef model compId newVal newText (replaceSymbol model newsymbol compId), Cmd.none - | ResetModel -> + | ResetModel -> { model with Symbols = Map.empty; Ports = Map.empty; }, Cmd.none - + | LoadComponents (ldcs,comps) -> (loadComponents ldcs model comps), Cmd.none - + | WriteMemoryLine (compId, addr, value) -> writeMemoryLine model (compId, addr, value), Cmd.none | WriteMemoryType (compId, memory) -> (writeMemoryType model compId memory), Cmd.none - | UpdateMemory (compId, updateFn) -> + | UpdateMemory (compId, updateFn) -> (updateMemory model compId updateFn), Cmd.none | RotateLeft(compList, rotation) -> (transformSymbols (rotateSymbol rotation) model compList), Cmd.none - + | RotateAntiClockAng (compList, rotationDeg) -> (transformSymbols (rotateAntiClockByAng rotationDeg) model compList), Cmd.none | Flip(compList, orientation) -> (transformSymbols (flipSymbol orientation) model compList), Cmd.none - | MovePort (portId, pos) -> + | MovePort (portId, pos) -> movePortUpdate model portId pos | MovePortDone (portId, pos)-> let port = model.Ports[portId] let symId = ComponentId port.HostId let oldSymbol = model.Symbols[symId] - let newSymbol = + let newSymbol = {(updatePortPos oldSymbol pos portId) with MovingPortTarget = None} |> autoScaleHAndW set (symbolOf_ symId) newSymbol model, Cmd.ofMsg (unbox UpdateBoundingBoxes) - + // HLP23 AUTHOR: BRYAN TAN | ShowCustomCorners compId -> showCompCorners model ShowAll compId, Cmd.none @@ -853,22 +853,24 @@ let update (msg : Msg) (model : Model): Model*Cmd<'a> = | None -> let newSymbol = set (appearance_ >-> showCorners_) DontShow model.Symbols[compId] set (symbolOf_ compId) newSymbol model, Cmd.none - + | SaveSymbols -> // want to add this message later, currently not used let newSymbols = Map.map storeLayoutInfoInComponent model.Symbols { model with Symbols = newSymbols }, Cmd.none | SetTheme (theme) -> - let resetSymbols = + let resetSymbols = model.Symbols - |> Map.map + |> Map.map (fun _ sym -> Optic.map appearance_ (set colour_ (getSymbolColour sym.Component.Type sym.IsClocked theme)) sym) {model with Theme=theme; Symbols = resetSymbols}, Cmd.none + + // ----------------------interface to Issie----------------------------- // -let extractComponent (symModel: Model) (sId:ComponentId) : Component = +let extractComponent (symModel: Model) (sId:ComponentId) : Component = let symbol = symModel.Symbols[sId] let symWithInfo = storeLayoutInfoInComponent () symbol symWithInfo.Component diff --git a/src/Renderer/Model/DrawModelType.fs b/src/Renderer/Model/DrawModelType.fs index 38aa597e0..53512a589 100644 --- a/src/Renderer/Model/DrawModelType.fs +++ b/src/Renderer/Model/DrawModelType.fs @@ -16,7 +16,7 @@ type SnapData = { LowerLimit: float Snap: float /// DisplayLine may not be the same as Snap because when two symbols snap together the - /// displayed line must go through the centre of each symbol, whereas the TopLeft + /// displayed line must go through the centre of each symbol, whereas the TopLeft /// coordinate is the one which is snapped IndicatorPos: float } @@ -35,9 +35,9 @@ let snapIndicatorPos_ = Lens.create (fun s -> s.SnapIndicatorPos) (fun u s -> {s /// All the 1D data needed to manage snapping of a moving symbol type SnapInfo = { /// static data - set of "snap" positions - SnapData: SnapData array + SnapData: SnapData array /// dynamic data - present if symbol is currently snapped - SnapOpt: Snap option + SnapOpt: Snap option } // lenses to access fields in the above types @@ -67,7 +67,7 @@ module SymbolT = /// data structures defining where ports are put on symbol boundary /// strings here are used for port ids type PortMaps = - { + { /// Maps edge to list of ports on that edge, in correct order Order: Map /// Maps the port ids to which side of the component the port is on @@ -78,8 +78,8 @@ module SymbolT = let orientation_ = Lens.create (fun a -> a.Orientation) (fun s a -> {a with Orientation = s}) /// data here changes how the symbol looks but has no other effect - type ShowPorts = | ShowInput | ShowOutput | ShowBoth | ShowBothForPortMovement | ShowNone | ShowOneTouching of Port | ShowOneNotTouching of Port | ShowTarget - + type ShowPorts = | ShowInput | ShowOutput | ShowBoth | ShowBothForPortMovement | ShowNone | ShowOneTouching of Port | ShowOneNotTouching of Port | ShowTarget + // HLP23 AUTHOR: BRYAN TAN type ShowCorners = | ShowAll | DontShow type Annotation = ScaleButton | RotateButton of Rotation @@ -94,7 +94,7 @@ module SymbolT = /// symbol color is determined by symbol selected / not selected, or if there are errors. Colour: string /// translucent symbols are used uring symbol copy operations. - Opacity: float + Opacity: float } /// This defines the colors used in teh drawblack, and therfore also the symbol color. @@ -123,7 +123,7 @@ module SymbolT = /// symbol's centre to the selected components' boundingBox centre when ScaleButton is pressed OffsetFromBBCentre: XYPos - + /// Width of the wires connected to input ports 0 & 1 /// This is needed on the symbol only for bus splitter and bus merge symbols /// These display the bit numbers of their connections. @@ -141,14 +141,14 @@ module SymbolT = LabelBoundingBox: BoundingBox LabelHasDefaultPos: bool LabelRotation: Rotation option - + /// this filed contains transient information that alters the appearance of the symbol Appearance: AppearanceT /// This, for convenience, is a copy of the component Id string, used as Id for symbol /// Thus symbol Id = component Id. /// It is unique within one design sheet. - Id : ComponentId + Id : ComponentId /// This is the electrical component. /// When the component is loaded into draw block the position is kept as Pos field in symbol @@ -161,7 +161,7 @@ module SymbolT = /// Use Some Annotation for visible (and clickable) objects on screen /// In this case Component is a dummy used only to provide expected H & V Annotation: Annotation option - + /// transient field to show if ports are being dragged in teh UI. Moving: bool /// determines whetehr the symbol or its contents (it it is a custom component) contain any clo9cked logic. @@ -250,8 +250,8 @@ module SymbolT = | PasteSymbols of sIds: ComponentId list | ColorSymbols of compList : ComponentId list * colour : HighLightColor | ErrorSymbols of errorIds: ComponentId list * selectIds: ComponentId list * isDragAndDrop: bool - | ChangeNumberOfBits of compId:ComponentId * NewBits:int - | ChangeLsb of compId: ComponentId * NewBits:int64 + | ChangeNumberOfBits of compId:ComponentId * NewBits:int + | ChangeLsb of compId: ComponentId * NewBits:int64 | ChangeInputValue of compId: ComponentId * newVal: int | ChangeScale of compId:ComponentId * newScale:float * whichScale:ScaleAdjustment | ChangeConstant of compId: ComponentId * NewBits:int64 * NewText:string @@ -261,7 +261,7 @@ module SymbolT = | ChangeCounterComponent of compId: ComponentId * oldComp: Component * newComp: ComponentType | ResetModel // For Issie Integration | LoadComponents of LoadedComponent list * Component list // For Issie Integration - | WriteMemoryLine of ComponentId * int64 * int64 // For Issie Integration + | WriteMemoryLine of ComponentId * int64 * int64 // For Issie Integration | WriteMemoryType of ComponentId * ComponentType | UpdateMemory of ComponentId * (Memory1 -> Memory1) | RotateLeft of compList : ComponentId list * Rotation @@ -280,7 +280,8 @@ module SymbolT = //------------------------Sheet interface message----------------------------// | UpdateBoundingBoxes - + + let symbols_ = Lens.create (fun m -> m.Symbols) (fun s m -> {m with Symbols = s}) let ports_ = Lens.create (fun m -> m.Ports) (fun w m -> {m with Ports = w}) let symbolOf_ k = symbols_ >-> Map.valueForce_ "What? Symbol id lookup in model failed" k @@ -290,25 +291,25 @@ module SymbolT = //------------------------------------------------------------------------// //------------------------------BusWire Types-----------------------------// //------------------------------------------------------------------------// - + module BusWireT = [] type Orientation = | Vertical | Horizontal - + /// type SnapPosition = High | Mid | Low - + /// Represents how wires are rendered type WireType = Radial | Modern | Jump - + /// Represents how a wire segment is currently being routed [] type RoutingMode = Manual | Auto - + /// Used to represent a segment in a wire - type Segment = + type Segment = { Index: int Length : float @@ -323,7 +324,7 @@ module BusWireT = member inline this.GetId = this.Index,this.WireId /// return true if segment length is 0 to within FP tolerance member inline this.IsZero = abs this.Length < XYPos.epsilon - + /// Add absolute vertices to a segment type ASegment = { Start: XYPos @@ -340,10 +341,10 @@ module BusWireT = let delta = this.Start - this.End if abs delta.X > abs delta.Y then Horizontal else Vertical - + type Wire = { - WId: ConnectionId + WId: ConnectionId InputPort: InputPortId OutputPort: OutputPortId Color: HighLightColor @@ -355,19 +356,19 @@ module BusWireT = let segments_ = Lens.create (fun m -> m.Segments) (fun s m -> {m with Segments = s}) let mode_ = Lens.create (fun m -> m.Mode) (fun s m -> {m with Mode = s}) - - + + /// Defines offsets used to render wire width text type TextOffset = static member yOffset = 7. static member xOffset = 1. static member xLeftOffset = 20. - + type Model = { Symbol: SymbolT.Model Wires: Map - CopiedWires: Map + CopiedWires: Map SelectedSegment: SegmentId list LastMousePos: XYPos ErrorWires: list @@ -376,9 +377,9 @@ module BusWireT = ArrowDisplay: bool SnapToNet: bool } - + //----------------------------Message Type-----------------------------------// - + /// BusWire messages: see BusWire.update for more info type Msg = | Symbol of SymbolT.Msg // record containing messages from Symbol module @@ -416,14 +417,14 @@ module SheetT = // HLP 23: AUTHOR Khoury & Ismagilov // Types needed for scaling box type ScalingBox = { - ScaleButton: SymbolT.Symbol - RotateDeg90Button: SymbolT.Symbol - RotateDeg270Button: SymbolT.Symbol + ScaleButton: SymbolT.Symbol + RotateDeg90Button: SymbolT.Symbol + RotateDeg270Button: SymbolT.Symbol ScalingBoxBound: BoundingBox ButtonList: ComponentId list } - + /// Used to keep mouse movement (AKA velocity) info as well as position type XYPosMov = { @@ -480,10 +481,10 @@ module SheetT = | GrabLabel | GrabSymbol | Grabbing - | ResizeNESW // HLP23 AUTHOR: BRYAN TAN + | ResizeNESW // HLP23 AUTHOR: BRYAN TAN | ResizeNWSE with - member this.Text() = + member this.Text() = match this with | Default -> "default" | ClickablePort -> "move" @@ -493,7 +494,7 @@ module SheetT = | GrabSymbol -> "cell" | GrabLabel -> "grab" | Grabbing -> "grabbing" - | ResizeNESW -> "nesw-resize" + | ResizeNESW -> "nesw-resize" | ResizeNWSE -> "nwse-resize" /// For Keyboard messages @@ -520,7 +521,7 @@ module SheetT = | InProgress of int | Failed | Queued - + type CompilationStageLabel = | Synthesis | PlaceAndRoute @@ -582,8 +583,8 @@ module SheetT = | TickCompilation of float | FinishedCompilationStage | DebugSingleStep - | DebugStepAndRead of parts: int - | DebugRead of parts: int + | DebugStepAndRead of parts: int + | DebugRead of parts: int | OnDebugRead of data: int * viewer: int | DebugConnect | DebugDisconnect @@ -604,7 +605,7 @@ module SheetT = | NotDebugging | Paused | Running - + type ScalingDirection = ScaleUp | ScaleDown type Model = { @@ -663,8 +664,10 @@ module SheetT = DebugMappings: string array DebugIsConnected: bool DebugDevice: string option + // bool to keep track if developer mode tab is open + DeveloperModeTabActive: bool } - + open Operators let wire_ = Lens.create (fun m -> m.Wire) (fun w m -> {m with Wire = w}) let selectedComponents_ = Lens.create (fun m -> m.SelectedComponents) (fun sc m -> {m with SelectedComponents = sc}) @@ -687,3 +690,5 @@ module SheetT = let zoom_ = Lens.create (fun m -> m.Zoom) (fun w m -> {m with Zoom = w}) let scalingBox_ = Lens.create (fun m -> m.ScalingBox) (fun w m -> {m with ScalingBox = w}) + + let developerModeTabActive_ = Lens.create (fun m -> m.DeveloperModeTabActive) (fun w m -> {m with DeveloperModeTabActive = w}) diff --git a/src/Renderer/Model/ModelType.fs b/src/Renderer/Model/ModelType.fs index 4d73ba134..000018bfa 100644 --- a/src/Renderer/Model/ModelType.fs +++ b/src/Renderer/Model/ModelType.fs @@ -53,6 +53,7 @@ type RightTab = | Simulation | Build | Transition // hack to make a transition from Simulation to Catalog without a scrollbar artifact + | DeveloperMode type SimSubTab = | StepSim @@ -77,7 +78,7 @@ type PopupDialogData = { ImportDecisions : Map Int2: int64 option ProjectPath: string - MemorySetup : (int * int * InitMemData * string option) option // AddressWidth, WordWidth. + MemorySetup : (int * int * InitMemData * string option) option // AddressWidth, WordWidth. MemoryEditorData : MemoryEditorData option // For memory editor and viewer. Progress: PopupProgress option ConstraintTypeSel: ConstraintType option @@ -135,7 +136,7 @@ type UICommandType = | StartWaveSim | ViewWaveSim | CloseWaveSim - + //--------------------------------------------------------------- //---------------------WaveSim types----------------------------- //--------------------------------------------------------------- @@ -274,7 +275,7 @@ type SimulationProgress = { InitialClock: int FinalClock: int - ClocksPerChunk: int + ClocksPerChunk: int } type PopupProgress = @@ -344,7 +345,7 @@ type Msg = /// of the given WaveSimModel | GenerateWaveforms of WaveSimModel /// Generate waveforms according to the model paramerts of Wavesim - | GenerateCurrentWaveforms + | GenerateCurrentWaveforms /// Run, or rerun, the FastSimulation with the current state of the Canvas. | RefreshWaveSim of WaveSimModel /// Sets or clears ShowSheetDetail (clearing will remove all child values in the set) @@ -430,6 +431,19 @@ type Msg = | SendSeqMsgAsynch of seq | ContextMenuAction of e: Browser.Types.MouseEvent | ContextMenuItemClick of menuType:string * item:string * dispatch: (Msg -> unit) + // Keep track of Dev Mode Scroll Position + | UpdateScrollPosRightSelection of pos: XYPos * dispatch: ( Msg -> Unit) + /// For Dev Mode to set params + | SelectTracking of bool * ((string list) option) + | ToggleSettingsMenu + | ToggleBeautifyMenu + | ToggleSheetStats + | ToggleSymbolInfoTable + | ToggleSymbolPortsTable + | ToggleWireTable + | ToggleWireSegmentsTable + | ToggleSymbolPortMapsTable + //================================// @@ -516,7 +530,7 @@ type Model = { /// If the application has a modal spinner waiting for simulation Spinner: (Model -> Model) option - + /// Draw Canvas Sheet: DrawModelType.SheetT.Model @@ -541,7 +555,7 @@ type Model = { SelectedComponent : Component option // None if no component is selected. /// used during step simulation: simgraph for current clock tick CurrentStepSimulationStep : Result option // None if no simulation is running. - /// stores the generated truth table + /// stores the generated truth table CurrentTruthTable: Result option // None if no Truth Table is being displayed. /// style info for the truth table TTConfig: TTType @@ -552,9 +566,9 @@ type Model = { /// components and connections which are highlighted Hilighted : (ComponentId list * ConnectionId list) * ConnectionId list /// Components and connections that have been selected and copied. - Clipboard : CanvasState + Clipboard : CanvasState /// Track the last added component - LastCreatedComponent : Component option + LastCreatedComponent : Component option /// used to enable "SAVE" button SavedSheetIsOutOfDate : bool /// the project contains, as loadable components, the state of each of its sheets @@ -580,7 +594,20 @@ type Model = { UIState: UICommandType Option /// if true the "build" tab appears on the RHS BuildVisible: bool -} + /// used for developer mode + RightSelectionScrollPos : XYPos + SettingsMenuExpanded: bool + Tracking: bool + HeldCounterValues: string list option + BeautifyMenuExpanded: bool + SymbolInfoTableExpanded: bool + SymbolPortsTableExpanded: bool + SymbolPortMapsTableExpanded: bool + WireTableExpanded: bool + WireSegmentsTableExpanded: bool + SheetStatsExpanded: bool + +} with member this.WaveSimOrCurrentSheet = match this.WaveSimSheet, this.CurrentProj with diff --git a/src/Renderer/Renderer.fs b/src/Renderer/Renderer.fs index a341686c2..c9db11bd1 100644 --- a/src/Renderer/Renderer.fs +++ b/src/Renderer/Renderer.fs @@ -1,437 +1,437 @@ -(* -Top-level renderer that initialises the app and runs the elmish loop -The electron built-in menus, and key presses,have actions which are -are implemented here using elmish subscriptions -*) - -module Renderer - -open Elmish -open Elmish.React -open Elmish.Debug -open Elmish.HMR -open Fable.Core -open Fable.Core.JsInterop -open ElectronAPI -open ModelType -open Fable.SimpleJson -open JSHelpers -open Sheet.SheetInterface -open DrawModelType -open Optics -open Optics.Operators -open TestParser -open ContextMenus - -importSideEffects "./scss/main.css" - -let isMac = Node.Api.``process``.platform = Node.Base.Darwin - -(**************************************************************************************************** -* -* MENU HELPER FUNCTIONS -* -****************************************************************************************************) - -let menuSeparator = - let sep = createEmpty - sep.``type`` <- Some MenuItemType.Separator - sep - -// Set up window close interlock using IPC from/to main process -let attachExitHandler dispatch = - // set up callback called when attempt is made to close main window - renderer.ipcRenderer.on ("closingWindow", (fun (event: Event)-> - // send a message which will process the request to exit - dispatch <| MenuAction(MenuExit,dispatch) +(* +Top-level renderer that initialises the app and runs the elmish loop +The electron built-in menus, and key presses,have actions which are +are implemented here using elmish subscriptions +*) + +module Renderer + +open Elmish +open Elmish.React +open Elmish.Debug +open Elmish.HMR +open Fable.Core +open Fable.Core.JsInterop +open ElectronAPI +open ModelType +open Fable.SimpleJson +open JSHelpers +open Sheet.SheetInterface +open DrawModelType +open Optics +open Optics.Operators +open TestParser +open ContextMenus + +importSideEffects "./scss/main.css" + +let isMac = Node.Api.``process``.platform = Node.Base.Darwin + +(**************************************************************************************************** +* +* MENU HELPER FUNCTIONS +* +****************************************************************************************************) + +let menuSeparator = + let sep = createEmpty + sep.``type`` <- Some MenuItemType.Separator + sep + +// Set up window close interlock using IPC from/to main process +let attachExitHandler dispatch = + // set up callback called when attempt is made to close main window + renderer.ipcRenderer.on ("closingWindow", (fun (event: Event)-> + // send a message which will process the request to exit + dispatch <| MenuAction(MenuExit,dispatch) )) |> ignore - renderer.ipcRenderer.on ("windowLostFocus", (fun (event: Event)-> - // send a message which will process the request to exit - dispatch <| MenuAction(MenuLostFocus,dispatch) - )) |> ignore -(* -// Set up window close interlock using IPC from/to main process -let attachGetAppHandler dispatch = - // set up callback called when attempt is made to close main window - renderer.ipcRenderer.on ("get-user-data", (fun (event: Event)-> - // send a message which will process the request to exit - dispatch <| SetUserAppDir (unbox event. : string) - )) |> ignore*) - -let getUserAppDir () : string = - unbox <| renderer.ipcRenderer.sendSync("get-user-data",None) - -/// Make action menu item from name, opt key to trigger, and action. -let makeItem (label : string) (accelerator : string option) (iAction : KeyboardEvent -> unit) = - let item = createEmpty - item.label <- Some label - item.accelerator <- accelerator - item.click <- Some (fun _ _ keyEvent -> iAction keyEvent) - item - -/// Make role menu from name, opt key to trigger, and action. -let makeRoleItem label accelerator role = - let item = makeItem label accelerator (fun _ -> ()) - item.role <- Some role - item - -/// make conditional menu item from condition, name, opt key to trigger, and role -let makeCondRoleItem cond label accelerator role = - let item = makeItem label accelerator (fun _ -> ()) - item.role <- Some role - item.visible <- Some cond - item - -/// make a conditional menu item from a condition, -/// name, opt key to trigger, and action -let makeCondItem cond label accelerator action = - let item = makeItem label accelerator action - item.visible <- Some cond - item - -/// A menu item which is visible only if in debug mode -/// (run dev or command line -D on binaries) and on windows. -let makeDebugItem label accelerator option = - makeCondItem (JSHelpers.debugLevel <> 0) label accelerator option - -/// A menu item which is visible only if in debug mode -/// (run dev or command line -D on binaries) and on windows. -let makeWinDebugItem label accelerator option = - makeCondItem (JSHelpers.debugLevel <> 0 && not isMac) label accelerator option - -/// Make -let makeElmItem (label:string) (accelerator : string) (action : unit -> unit) = - jsOptions <| fun item -> - item.label <- Some label - item.accelerator <- Some accelerator - item.click <- Some (fun _ _ _ -> action()) - - -/// Make a new menu from a list of menu items -let makeMenuGen (visible: bool) (topLevel: bool) (name : string) (table : MenuItemConstructorOptions list) = - let subMenu = createEmpty - subMenu.``type`` <- Some (if topLevel then MenuItemType.Normal else MenuItemType.Submenu) - subMenu.label <-Some name - subMenu.submenu <- Some (U2.Case1 (table |> ResizeArray)) - subMenu.visible <- Some visible - subMenu - - -/// Make a new menu from a list of menu items -let makeMenu (topLevel: bool) (name : string) (table : MenuItemConstructorOptions list) = - makeMenuGen true topLevel name table - -open JSHelpers - -let reSeparateWires dispatch = - dispatch <| UpdateModel (fun model -> - model - |> Optic.map (sheet_ >-> SheetT.wire_) (BusWireSeparate.reSeparateWiresFrom model.Sheet.SelectedComponents) - ) - -let reRouteWires dispatch = - dispatch <| UpdateModel (fun model -> - model - |> Optic.map (sheet_ >-> SheetT.wire_) (BusWireSeparate.reRouteWiresFrom model.Sheet.SelectedComponents) - ) - -//-----------------------------------------------------------------------------------------------------------// -//-----------------------------------------------FILE MENU---------------------------------------------------// -//-----------------------------------------------------------------------------------------------------------// - -let fileMenu (dispatch) = - makeMenu false "Sheet" [ - makeItem "New Sheet" (Some "CmdOrCtrl+N") (fun ev -> dispatch (MenuAction(MenuNewFile,dispatch))) - makeItem "Save Sheet" (Some "CmdOrCtrl+S") (fun ev -> dispatch (MenuAction(MenuSaveFile,dispatch))) - makeItem "Save Project in New Format" None (fun ev -> dispatch (MenuAction(MenuSaveProjectInNewFormat,dispatch))) - //makeItem "Print Sheet" (Some "CmdOrCtrl+P") (fun ev -> dispatch (MenuAction(MenuPrint,dispatch))) - makeItem "Write design as Verilog" None (fun ev -> dispatch (MenuAction(MenuVerilogOutput,dispatch))) - makeItem "Exit Issie" None (fun ev -> dispatch (MenuAction(MenuExit,dispatch))) - makeItem ("About Issie " + Version.VersionString) None (fun ev -> UIPopups.viewInfoPopup dispatch) - makeCondRoleItem (debugLevel <> 0 && not isMac) "Hard Restart app" None MenuItemRole.ForceReload - makeWinDebugItem "Trace all" None (fun _ -> - debugTraceUI <- Set.ofList ["update";"view"]) - makeWinDebugItem "Trace View function" None (fun _ -> - debugTraceUI <- Set.ofList ["view"]) - makeWinDebugItem "Trace Update function" None (fun _ -> - debugTraceUI <- Set.ofList ["update"]) - makeWinDebugItem "Trace off" None (fun _ -> - debugTraceUI <- Set.ofList []) - makeMenuGen (debugLevel > 0) false "Play" [ - makeDebugItem "Set Scroll" None - (fun _ -> SheetDisplay.writeCanvasScroll {X=1000.;Y=1000.}) - makeDebugItem "Trace all times" None - (fun _ -> TimeHelpers.instrumentation <- TimeHelpers.ImmediatePrint( 0.1, 0.1) - if debugTraceUI = Set.ofList [] then debugTraceUI <- Set.ofList ["update";"view"]) - makeDebugItem "Trace short, medium & long times" None - (fun _ -> TimeHelpers.instrumentation <- TimeHelpers.ImmediatePrint( 1.5, 1.5) - if debugTraceUI = Set.ofList [] then debugTraceUI <- Set.ofList ["update";"view"]) - makeDebugItem "Trace medium & long times" None - (fun _ -> TimeHelpers.instrumentation <- TimeHelpers.ImmediatePrint(3.,3.) - if debugTraceUI = Set.ofList [] then debugTraceUI <- Set.ofList ["update";"view"]) - makeDebugItem "Trace long times" None - (fun _ -> TimeHelpers.instrumentation <- TimeHelpers.ImmediatePrint(20.,20.) - if debugTraceUI = Set.ofList [] then debugTraceUI <- Set.ofList ["update";"view"]) - makeDebugItem "Highlight debugChangedConnections" None - (fun _ -> Playground.Misc.highLightChangedConnections dispatch) - makeDebugItem "Test Fonts" None - (fun _ -> Playground.TestFonts.makeTextPopup dispatch) - makeWinDebugItem "Run performance check" None - (fun _ -> Playground.MiscTests.testMaps()) - makeWinDebugItem "Print names of static asset files" None - (fun _ -> Playground.MiscTests.testAssets()) - makeWinDebugItem "Test Breadcrumbs" None - (fun _ -> dispatch <| Msg.ExecFuncInMessage(Playground.Breadcrumbs.testBreadcrumbs,dispatch)) - makeWinDebugItem "Test All Hierarchies Breadcrumbs" None - (fun _ -> dispatch <| Msg.ExecFuncInMessage(Playground.Breadcrumbs.testAllHierarchiesBreadcrumbs,dispatch)) - - makeDebugItem "Force Exception" None - (fun ev -> failwithf "User exception from menus") - - makeDebugItem "Web worker performance test" None - (fun _ -> Playground.WebWorker.testWorkers Playground.WebWorker.Constants.workerTestConfig) - - - ] - - makeMenu false "Verilog" [ - makeDebugItem "Run Verilog tests" None (fun _ -> - runCompilerTests () - printfn "Compiler tests done") - makeDebugItem "Run Verilog performance tests" None (fun _ -> - runPerformanceTests () - printfn "Performance tests done") - makeDebugItem "Generate driver modules" None (fun _ -> - genDriverFiles ()) - makeDebugItem "Icarus compile testcases" None (fun _ -> - icarusCompileTestCases ()) - makeDebugItem "Icarus run testcases" None (fun _ -> - icarusRunTestCases ()) - ] - ] - -//-----------------------------------------------------------------------------------------------------------// -//-----------------------------------------------VIEW MENU---------------------------------------------------// -//-----------------------------------------------------------------------------------------------------------// - - -let viewMenu dispatch = - let maindispatch = dispatch - let sheetDispatch sMsg = dispatch (Sheet sMsg) - let dispatch = SheetT.KeyPress >> sheetDispatch - let wireTypeDispatch = SheetT.WireType >> sheetDispatch - let interfaceDispatch = SheetT.IssieInterface >> sheetDispatch - let busWireDispatch (bMsg: BusWireT.Msg) = sheetDispatch (SheetT.Msg.Wire bMsg) - - - - let symbolDispatch msg = busWireDispatch (BusWireT.Msg.Symbol msg) - - let devToolsKey = if isMac then "Alt+Command+I" else "Ctrl+Shift+I" - makeMenu false "View" [ - makeRoleItem "Toggle Fullscreen" (Some "F11") MenuItemRole.Togglefullscreen - menuSeparator - makeRoleItem "Zoom In" (Some "CmdOrCtrl+Shift+Plus") MenuItemRole.ZoomIn - makeRoleItem "Zoom Out" (Some "CmdOrCtrl+Shift+-") MenuItemRole.ZoomOut - makeRoleItem "Reset Zoom" (Some "CmdOrCtrl+0") MenuItemRole.ResetZoom - menuSeparator - makeItem "Diagram Zoom In" (Some "Alt+Up") (fun ev -> dispatch SheetT.KeyboardMsg.ZoomIn) - makeItem "Diagram Zoom Out" (Some "Alt+Down") (fun ev -> dispatch SheetT.KeyboardMsg.ZoomOut) - makeItem "Diagram Zoom to Fit" (Some "CmdOrCtrl+W") (fun ev -> dispatch SheetT.KeyboardMsg.CtrlW) - menuSeparator - makeItem "Toggle Grid" None (fun ev -> sheetDispatch SheetT.Msg.ToggleGrid) - makeMenu false "Theme" [ - makeItem "Grayscale" None (fun ev -> - maindispatch <| SetThemeUserData SymbolT.ThemeType.White - symbolDispatch (SymbolT.Msg.SetTheme SymbolT.ThemeType.White) - ) - makeItem "Light" None (fun ev -> - maindispatch <| SetThemeUserData SymbolT.ThemeType.Light - symbolDispatch (SymbolT.Msg.SetTheme SymbolT.ThemeType.Light) - ) - makeItem "Colourful" None (fun ev -> - maindispatch <| SetThemeUserData SymbolT.ThemeType.Colourful - symbolDispatch (SymbolT.Msg.SetTheme SymbolT.ThemeType.Colourful) - ) - ] - makeItem "Toggle Wire Arrows" None (fun ev -> busWireDispatch (BusWireT.Msg.ToggleArrowDisplay)) - makeMenu false "Wire Type" [ - makeItem "Jump wires" None (fun ev -> wireTypeDispatch SheetT.WireTypeMsg.Jump) - makeItem "Radiussed wires" None (fun ev -> wireTypeDispatch SheetT.WireTypeMsg.Radiussed) - makeItem "Modern wires" None (fun ev -> wireTypeDispatch SheetT.WireTypeMsg.Modern) - ] - menuSeparator - makeItem "Benchmark" (Some "Ctrl+Shift+B") (fun ev -> maindispatch Benchmark) - makeItem "Show/Hide Build Tab" None (fun ev -> maindispatch (ChangeBuildTabVisibility)) - menuSeparator - makeCondItem (JSHelpers.debugLevel <> 0) "Toggle Dev Tools" (Some devToolsKey) (fun _ -> - renderer.ipcRenderer.send("toggle-dev-tools", [||]) |> ignore) - ] - -//-----------------------------------------------------------------------------------------------------------// -//-----------------------------------------------EDIT MENU---------------------------------------------------// -//-----------------------------------------------------------------------------------------------------------// - -// Editor Keybindings (also items on Edit menu) -// Use Elmish subscriptions to attach external source of events such as keyboard -// shortcuts. According to electron documentation, the way to configure keyboard -// shortcuts is by creating a menu. -let editMenu dispatch' = - let sheetDispatch sMsg = dispatch' (Sheet sMsg) - let dispatch = SheetT.KeyPress >> sheetDispatch - let rotateDispatch = SheetT.Rotate >> sheetDispatch - let busWireDispatch (bMsg: BusWireT.Msg) = sheetDispatch (SheetT.Msg.Wire bMsg) - - jsOptions <| fun invisibleMenu -> - invisibleMenu.``type`` <- Some MenuItemType.Submenu - invisibleMenu.label <- Some "Edit" - invisibleMenu.visible <- Some true - invisibleMenu.submenu <- - [| // makeElmItem "Save Sheet" "CmdOrCtrl+S" (fun () -> ()) - makeElmItem "Copy" "CmdOrCtrl+C" (fun () -> dispatch SheetT.KeyboardMsg.CtrlC) - makeElmItem "Paste" "CmdOrCtrl+V" (fun () -> dispatch SheetT.KeyboardMsg.CtrlV) - menuSeparator - makeElmItem "Rotate Anticlockwise" "CmdOrCtrl+Left" (fun () -> rotateDispatch CommonTypes.Degree270) - makeElmItem "Rotate Clockwise" "CmdOrCtrl+Right" (fun () -> rotateDispatch CommonTypes.Degree90) - makeElmItem "Flip Vertically" "CmdOrCtrl+Up" (fun () -> sheetDispatch <| SheetT.Flip SymbolT.FlipVertical) - makeElmItem "Flip Horizontally" "CmdOrCtrl+Down" (fun () -> sheetDispatch <| SheetT.Flip SymbolT.FlipHorizontal) - makeItem "Move Component Ports" None (fun _ -> - dispatch' <| ShowStaticInfoPopup("How to move component ports", SymbolPortHelpers.moveCustomPortsPopup(), dispatch')) - menuSeparator - makeElmItem "Align" "CmdOrCtrl+Shift+A" (fun ev -> sheetDispatch <| SheetT.Arrangement SheetT.AlignSymbols) - makeElmItem "Distribute" "CmdOrCtrl+Shift+D" (fun ev-> sheetDispatch <| SheetT.Arrangement SheetT.DistributeSymbols) - makeElmItem "Rotate Label Clockwise" "CmdOrCtrl+Shift+Right" (fun ev-> sheetDispatch <| SheetT.RotateLabels) - menuSeparator - makeElmItem "Select All" "CmdOrCtrl+A" (fun () -> dispatch SheetT.KeyboardMsg.CtrlA) - makeElmItem "Delete" (if isMac then "Backspace" else "delete") (fun () -> dispatch SheetT.KeyboardMsg.DEL) - makeElmItem "Undo" "CmdOrCtrl+Z" (fun () -> dispatch SheetT.KeyboardMsg.CtrlZ) - makeElmItem "Redo" "CmdOrCtrl+Y" (fun () -> dispatch SheetT.KeyboardMsg.CtrlY) - makeElmItem "Cancel" "ESC" (fun () -> dispatch SheetT.KeyboardMsg.ESC) - menuSeparator - makeItem "Separate Wires from Selected Components" None (fun _ -> reSeparateWires dispatch') - makeItem "Reroute Wires from Selected Components" None (fun _ -> reRouteWires dispatch') - |] - |> ResizeArray - |> U2.Case1 - |> Some - - -let attachMenusAndKeyShortcuts dispatch = - //setupExitInterlock dispatch - let sub dispatch = - let menu:Menu = - [| - - fileMenu dispatch - - editMenu dispatch - - viewMenu dispatch - |] - |> Array.map U2.Case1 - |> electronRemote.Menu.buildFromTemplate //Help? How do we call buildfromtemplate - menu.items[0].visible <- true - dispatch <| Msg.ExecFuncInMessage((fun _ _ -> - electronRemote.app.applicationMenu <- Some menu), dispatch) - attachExitHandler dispatch - let userAppDir = getUserAppDir() - dispatch <| ReadUserData userAppDir - - - Cmd.ofSub sub - -// This setup is useful to add other pages, in case they are needed. - -type Model = ModelType.Model - -type Messages = ModelType.Msg - -// -- Init Model - -let init() = - JSHelpers.setDebugLevel() - DiagramMainView.init(), Cmd.none - - -// -- Create View -let addDebug dispatch (msg:Msg) = - let str = UpdateHelpers.getMessageTraceString msg - //if str <> "" then printfn ">>Dispatch %s" str else () - dispatch msg - -let view model dispatch = DiagramMainView.displayView model (addDebug dispatch) - -// -- Update Model - -let update msg model = Update.update msg model - -printfn "Starting renderer..." - -let view' model dispatch = - let start = TimeHelpers.getTimeMs() - view model dispatch - |> (fun view -> - if Set.contains "view" JSHelpers.debugTraceUI then - TimeHelpers.instrumentInterval ">>>View" start view - else - view) - -let mutable firstPress = true - -///Used to listen for pressing down of Ctrl for selection toggle -let keyPressListener initial = - let subDown dispatch = - Browser.Dom.document.addEventListener("keydown", fun e -> - let ke: KeyboardEvent = downcast e - if (jsToBool ke.ctrlKey || jsToBool ke.metaKey) && firstPress then + renderer.ipcRenderer.on ("windowLostFocus", (fun (event: Event)-> + // send a message which will process the request to exit + dispatch <| MenuAction(MenuLostFocus,dispatch) + )) |> ignore +(* +// Set up window close interlock using IPC from/to main process +let attachGetAppHandler dispatch = + // set up callback called when attempt is made to close main window + renderer.ipcRenderer.on ("get-user-data", (fun (event: Event)-> + // send a message which will process the request to exit + dispatch <| SetUserAppDir (unbox event. : string) + )) |> ignore*) + +let getUserAppDir () : string = + unbox <| renderer.ipcRenderer.sendSync("get-user-data",None) + +/// Make action menu item from name, opt key to trigger, and action. +let makeItem (label : string) (accelerator : string option) (iAction : KeyboardEvent -> unit) = + let item = createEmpty + item.label <- Some label + item.accelerator <- accelerator + item.click <- Some (fun _ _ keyEvent -> iAction keyEvent) + item + +/// Make role menu from name, opt key to trigger, and action. +let makeRoleItem label accelerator role = + let item = makeItem label accelerator (fun _ -> ()) + item.role <- Some role + item + +/// make conditional menu item from condition, name, opt key to trigger, and role +let makeCondRoleItem cond label accelerator role = + let item = makeItem label accelerator (fun _ -> ()) + item.role <- Some role + item.visible <- Some cond + item + +/// make a conditional menu item from a condition, +/// name, opt key to trigger, and action +let makeCondItem cond label accelerator action = + let item = makeItem label accelerator action + item.visible <- Some cond + item + +/// A menu item which is visible only if in debug mode +/// (run dev or command line -D on binaries) and on windows. +let makeDebugItem label accelerator option = + makeCondItem (JSHelpers.debugLevel <> 0) label accelerator option + +/// A menu item which is visible only if in debug mode +/// (run dev or command line -D on binaries) and on windows. +let makeWinDebugItem label accelerator option = + makeCondItem (JSHelpers.debugLevel <> 0 && not isMac) label accelerator option + +/// Make +let makeElmItem (label:string) (accelerator : string) (action : unit -> unit) = + jsOptions <| fun item -> + item.label <- Some label + item.accelerator <- Some accelerator + item.click <- Some (fun _ _ _ -> action()) + + +/// Make a new menu from a list of menu items +let makeMenuGen (visible: bool) (topLevel: bool) (name : string) (table : MenuItemConstructorOptions list) = + let subMenu = createEmpty + subMenu.``type`` <- Some (if topLevel then MenuItemType.Normal else MenuItemType.Submenu) + subMenu.label <-Some name + subMenu.submenu <- Some (U2.Case1 (table |> ResizeArray)) + subMenu.visible <- Some visible + subMenu + + +/// Make a new menu from a list of menu items +let makeMenu (topLevel: bool) (name : string) (table : MenuItemConstructorOptions list) = + makeMenuGen true topLevel name table + +open JSHelpers + +let reSeparateWires dispatch = + dispatch <| UpdateModel (fun model -> + model + |> Optic.map (sheet_ >-> SheetT.wire_) (BusWireSeparate.reSeparateWiresFrom model.Sheet.SelectedComponents) + ) + +let reRouteWires dispatch = + dispatch <| UpdateModel (fun model -> + model + |> Optic.map (sheet_ >-> SheetT.wire_) (BusWireSeparate.reRouteWiresFrom model.Sheet.SelectedComponents) + ) + +//-----------------------------------------------------------------------------------------------------------// +//-----------------------------------------------FILE MENU---------------------------------------------------// +//-----------------------------------------------------------------------------------------------------------// + +let fileMenu (dispatch) = + makeMenu false "Sheet" [ + makeItem "New Sheet" (Some "CmdOrCtrl+N") (fun ev -> dispatch (MenuAction(MenuNewFile,dispatch))) + makeItem "Save Sheet" (Some "CmdOrCtrl+S") (fun ev -> dispatch (MenuAction(MenuSaveFile,dispatch))) + makeItem "Save Project in New Format" None (fun ev -> dispatch (MenuAction(MenuSaveProjectInNewFormat,dispatch))) + //makeItem "Print Sheet" (Some "CmdOrCtrl+P") (fun ev -> dispatch (MenuAction(MenuPrint,dispatch))) + makeItem "Write design as Verilog" None (fun ev -> dispatch (MenuAction(MenuVerilogOutput,dispatch))) + makeItem "Exit Issie" None (fun ev -> dispatch (MenuAction(MenuExit,dispatch))) + makeItem ("About Issie " + Version.VersionString) None (fun ev -> UIPopups.viewInfoPopup dispatch) + makeCondRoleItem (debugLevel <> 0 && not isMac) "Hard Restart app" None MenuItemRole.ForceReload + makeWinDebugItem "Trace all" None (fun _ -> + debugTraceUI <- Set.ofList ["update";"view"]) + makeWinDebugItem "Trace View function" None (fun _ -> + debugTraceUI <- Set.ofList ["view"]) + makeWinDebugItem "Trace Update function" None (fun _ -> + debugTraceUI <- Set.ofList ["update"]) + makeWinDebugItem "Trace off" None (fun _ -> + debugTraceUI <- Set.ofList []) + makeMenuGen (debugLevel > 0) false "Play" [ + makeDebugItem "Set Scroll" None + (fun _ -> SheetDisplay.writeCanvasScroll {X=1000.;Y=1000.}) + makeDebugItem "Trace all times" None + (fun _ -> TimeHelpers.instrumentation <- TimeHelpers.ImmediatePrint( 0.1, 0.1) + if debugTraceUI = Set.ofList [] then debugTraceUI <- Set.ofList ["update";"view"]) + makeDebugItem "Trace short, medium & long times" None + (fun _ -> TimeHelpers.instrumentation <- TimeHelpers.ImmediatePrint( 1.5, 1.5) + if debugTraceUI = Set.ofList [] then debugTraceUI <- Set.ofList ["update";"view"]) + makeDebugItem "Trace medium & long times" None + (fun _ -> TimeHelpers.instrumentation <- TimeHelpers.ImmediatePrint(3.,3.) + if debugTraceUI = Set.ofList [] then debugTraceUI <- Set.ofList ["update";"view"]) + makeDebugItem "Trace long times" None + (fun _ -> TimeHelpers.instrumentation <- TimeHelpers.ImmediatePrint(20.,20.) + if debugTraceUI = Set.ofList [] then debugTraceUI <- Set.ofList ["update";"view"]) + makeDebugItem "Highlight debugChangedConnections" None + (fun _ -> Playground.Misc.highLightChangedConnections dispatch) + makeDebugItem "Test Fonts" None + (fun _ -> Playground.TestFonts.makeTextPopup dispatch) + makeWinDebugItem "Run performance check" None + (fun _ -> Playground.MiscTests.testMaps()) + makeWinDebugItem "Print names of static asset files" None + (fun _ -> Playground.MiscTests.testAssets()) + makeWinDebugItem "Test Breadcrumbs" None + (fun _ -> dispatch <| Msg.ExecFuncInMessage(Playground.Breadcrumbs.testBreadcrumbs,dispatch)) + makeWinDebugItem "Test All Hierarchies Breadcrumbs" None + (fun _ -> dispatch <| Msg.ExecFuncInMessage(Playground.Breadcrumbs.testAllHierarchiesBreadcrumbs,dispatch)) + + makeDebugItem "Force Exception" None + (fun ev -> failwithf "User exception from menus") + + makeDebugItem "Web worker performance test" None + (fun _ -> Playground.WebWorker.testWorkers Playground.WebWorker.Constants.workerTestConfig) + + + ] + + makeMenu false "Verilog" [ + makeDebugItem "Run Verilog tests" None (fun _ -> + runCompilerTests () + printfn "Compiler tests done") + makeDebugItem "Run Verilog performance tests" None (fun _ -> + runPerformanceTests () + printfn "Performance tests done") + makeDebugItem "Generate driver modules" None (fun _ -> + genDriverFiles ()) + makeDebugItem "Icarus compile testcases" None (fun _ -> + icarusCompileTestCases ()) + makeDebugItem "Icarus run testcases" None (fun _ -> + icarusRunTestCases ()) + ] + ] + +//-----------------------------------------------------------------------------------------------------------// +//-----------------------------------------------VIEW MENU---------------------------------------------------// +//-----------------------------------------------------------------------------------------------------------// + + +let viewMenu dispatch = + let maindispatch = dispatch + let sheetDispatch sMsg = dispatch (Sheet sMsg) + let dispatch = SheetT.KeyPress >> sheetDispatch + let wireTypeDispatch = SheetT.WireType >> sheetDispatch + let interfaceDispatch = SheetT.IssieInterface >> sheetDispatch + let busWireDispatch (bMsg: BusWireT.Msg) = sheetDispatch (SheetT.Msg.Wire bMsg) + + + + let symbolDispatch msg = busWireDispatch (BusWireT.Msg.Symbol msg) + + let devToolsKey = if isMac then "Alt+Command+I" else "Ctrl+Shift+I" + makeMenu false "View" [ + makeRoleItem "Toggle Fullscreen" (Some "F11") MenuItemRole.Togglefullscreen + menuSeparator + makeRoleItem "Zoom In" (Some "CmdOrCtrl+Shift+Plus") MenuItemRole.ZoomIn + makeRoleItem "Zoom Out" (Some "CmdOrCtrl+Shift+-") MenuItemRole.ZoomOut + makeRoleItem "Reset Zoom" (Some "CmdOrCtrl+0") MenuItemRole.ResetZoom + menuSeparator + makeItem "Diagram Zoom In" (Some "Alt+Up") (fun ev -> dispatch SheetT.KeyboardMsg.ZoomIn) + makeItem "Diagram Zoom Out" (Some "Alt+Down") (fun ev -> dispatch SheetT.KeyboardMsg.ZoomOut) + makeItem "Diagram Zoom to Fit" (Some "CmdOrCtrl+W") (fun ev -> dispatch SheetT.KeyboardMsg.CtrlW) + menuSeparator + makeItem "Toggle Grid" None (fun ev -> sheetDispatch SheetT.Msg.ToggleGrid) + makeMenu false "Theme" [ + makeItem "Grayscale" None (fun ev -> + maindispatch <| SetThemeUserData SymbolT.ThemeType.White + symbolDispatch (SymbolT.Msg.SetTheme SymbolT.ThemeType.White) + ) + makeItem "Light" None (fun ev -> + maindispatch <| SetThemeUserData SymbolT.ThemeType.Light + symbolDispatch (SymbolT.Msg.SetTheme SymbolT.ThemeType.Light) + ) + makeItem "Colourful" None (fun ev -> + maindispatch <| SetThemeUserData SymbolT.ThemeType.Colourful + symbolDispatch (SymbolT.Msg.SetTheme SymbolT.ThemeType.Colourful) + ) + ] + makeItem "Toggle Wire Arrows" None (fun ev -> busWireDispatch (BusWireT.Msg.ToggleArrowDisplay)) + makeMenu false "Wire Type" [ + makeItem "Jump wires" None (fun ev -> wireTypeDispatch SheetT.WireTypeMsg.Jump) + makeItem "Radiussed wires" None (fun ev -> wireTypeDispatch SheetT.WireTypeMsg.Radiussed) + makeItem "Modern wires" None (fun ev -> wireTypeDispatch SheetT.WireTypeMsg.Modern) + ] + menuSeparator + makeItem "Benchmark" (Some "Ctrl+Shift+B") (fun ev -> maindispatch Benchmark) + makeItem "Show/Hide Build Tab" None (fun ev -> maindispatch (ChangeBuildTabVisibility)) + menuSeparator + makeCondItem (JSHelpers.debugLevel <> 0) "Toggle Dev Tools" (Some devToolsKey) (fun _ -> + renderer.ipcRenderer.send("toggle-dev-tools", [||]) |> ignore) + ] + +//-----------------------------------------------------------------------------------------------------------// +//-----------------------------------------------EDIT MENU---------------------------------------------------// +//-----------------------------------------------------------------------------------------------------------// + +// Editor Keybindings (also items on Edit menu) +// Use Elmish subscriptions to attach external source of events such as keyboard +// shortcuts. According to electron documentation, the way to configure keyboard +// shortcuts is by creating a menu. +let editMenu dispatch' = + let sheetDispatch sMsg = dispatch' (Sheet sMsg) + let dispatch = SheetT.KeyPress >> sheetDispatch + let rotateDispatch = SheetT.Rotate >> sheetDispatch + let busWireDispatch (bMsg: BusWireT.Msg) = sheetDispatch (SheetT.Msg.Wire bMsg) + + jsOptions <| fun invisibleMenu -> + invisibleMenu.``type`` <- Some MenuItemType.Submenu + invisibleMenu.label <- Some "Edit" + invisibleMenu.visible <- Some true + invisibleMenu.submenu <- + [| // makeElmItem "Save Sheet" "CmdOrCtrl+S" (fun () -> ()) + makeElmItem "Copy" "CmdOrCtrl+C" (fun () -> dispatch SheetT.KeyboardMsg.CtrlC) + makeElmItem "Paste" "CmdOrCtrl+V" (fun () -> dispatch SheetT.KeyboardMsg.CtrlV) + menuSeparator + makeElmItem "Rotate Anticlockwise" "CmdOrCtrl+Left" (fun () -> rotateDispatch CommonTypes.Degree270) + makeElmItem "Rotate Clockwise" "CmdOrCtrl+Right" (fun () -> rotateDispatch CommonTypes.Degree90) + makeElmItem "Flip Vertically" "CmdOrCtrl+Up" (fun () -> sheetDispatch <| SheetT.Flip SymbolT.FlipVertical) + makeElmItem "Flip Horizontally" "CmdOrCtrl+Down" (fun () -> sheetDispatch <| SheetT.Flip SymbolT.FlipHorizontal) + makeItem "Move Component Ports" None (fun _ -> + dispatch' <| ShowStaticInfoPopup("How to move component ports", SymbolPortHelpers.moveCustomPortsPopup(), dispatch')) + menuSeparator + makeElmItem "Align" "CmdOrCtrl+Shift+A" (fun ev -> sheetDispatch <| SheetT.Arrangement SheetT.AlignSymbols) + makeElmItem "Distribute" "CmdOrCtrl+Shift+D" (fun ev-> sheetDispatch <| SheetT.Arrangement SheetT.DistributeSymbols) + makeElmItem "Rotate Label Clockwise" "CmdOrCtrl+Shift+Right" (fun ev-> sheetDispatch <| SheetT.RotateLabels) + menuSeparator + makeElmItem "Select All" "CmdOrCtrl+A" (fun () -> dispatch SheetT.KeyboardMsg.CtrlA) + makeElmItem "Delete" (if isMac then "Backspace" else "delete") (fun () -> dispatch SheetT.KeyboardMsg.DEL) + makeElmItem "Undo" "CmdOrCtrl+Z" (fun () -> dispatch SheetT.KeyboardMsg.CtrlZ) + makeElmItem "Redo" "CmdOrCtrl+Y" (fun () -> dispatch SheetT.KeyboardMsg.CtrlY) + makeElmItem "Cancel" "ESC" (fun () -> dispatch SheetT.KeyboardMsg.ESC) + menuSeparator + makeItem "Separate Wires from Selected Components" None (fun _ -> reSeparateWires dispatch') + makeItem "Reroute Wires from Selected Components" None (fun _ -> reRouteWires dispatch') + |] + |> ResizeArray + |> U2.Case1 + |> Some + + +let attachMenusAndKeyShortcuts dispatch = + //setupExitInterlock dispatch + let sub dispatch = + let menu:Menu = + [| + + fileMenu dispatch + + editMenu dispatch + + viewMenu dispatch + |] + |> Array.map U2.Case1 + |> electronRemote.Menu.buildFromTemplate //Help? How do we call buildfromtemplate + menu.items[0].visible <- true + dispatch <| Msg.ExecFuncInMessage((fun _ _ -> + electronRemote.app.applicationMenu <- Some menu), dispatch) + attachExitHandler dispatch + let userAppDir = getUserAppDir() + dispatch <| ReadUserData userAppDir + + + Cmd.ofSub sub + +// This setup is useful to add other pages, in case they are needed. + +type Model = ModelType.Model + +type Messages = ModelType.Msg + +// -- Init Model + +let init() = + JSHelpers.setDebugLevel() + DiagramMainView.init(), Cmd.none + + +// -- Create View +let addDebug dispatch (msg:Msg) = + let str = UpdateHelpers.getMessageTraceString msg + //if str <> "" then printfn ">>Dispatch %s" str else () + dispatch msg + +let view model dispatch = DiagramMainView.displayView model (addDebug dispatch) + +// -- Update Model + +let update msg model = Update.update msg model + +printfn "Starting renderer..." + +let view' model dispatch = + let start = TimeHelpers.getTimeMs() + view model dispatch + |> (fun view -> + if Set.contains "view" JSHelpers.debugTraceUI then + TimeHelpers.instrumentInterval ">>>View" start view + else + view) + +let mutable firstPress = true + +///Used to listen for pressing down of Ctrl for selection toggle +let keyPressListener initial = + let subDown dispatch = + Browser.Dom.document.addEventListener("keydown", fun e -> + let ke: KeyboardEvent = downcast e + if (jsToBool ke.ctrlKey || jsToBool ke.metaKey) && firstPress then firstPress <- false - //printf "Ctrl-Meta Key down (old method)" - dispatch <| Sheet(SheetT.PortMovementStart) - else - ()) - let subUp dispatch = - Browser.Dom.document.addEventListener("keyup", fun e -> + //printf "Ctrl-Meta Key down (old method)" + dispatch <| Sheet(SheetT.PortMovementStart) + else + ()) + let subUp dispatch = + Browser.Dom.document.addEventListener("keyup", fun e -> firstPress <- true - //printf "Any Key up (old method)" - dispatch <| Sheet(SheetT.PortMovementEnd)) - /// unfinished code - /// add hook in main function to display a context menu - /// create menu as shown in main.fs - let subRightClick dispatch = - Browser.Dom.document.addEventListener("contextmenu", unbox (fun (e:Browser.Types.MouseEvent) -> - e.preventDefault() - //printfn "Context Menu listener sending to main..." - dispatch (ContextMenuAction e))) - - - let subContextMenuCommand dispatch = - renderer.ipcRenderer.on("context-menu-command", fun ev args -> - let arg:string = unbox args |> Array.map string |> String.concat "" - printfn "%s" arg - match arg.Split [|','|] |> Array.toList with - | [ menuType ; item ] -> - //printfn "%A" $"Renderer context menu callback: {menuType} --> {item}" - dispatch <| ContextMenuItemClick(menuType,item,dispatch) - | _ -> printfn "Unexpected callback argument sent from main.") |> ignore - - Cmd.batch [ - Cmd.ofSub subDown - Cmd.ofSub subUp - Cmd.ofSub subRightClick - Cmd.ofSub subContextMenuCommand - ] - - - - - - - - - - -Program.mkProgram init update view' -|> Program.withReactBatched "app" -|> Program.withSubscription attachMenusAndKeyShortcuts -|> Program.withSubscription keyPressListener -|> Program.run + //printf "Any Key up (old method)" + dispatch <| Sheet(SheetT.PortMovementEnd)) + /// unfinished code + /// add hook in main function to display a context menu + /// create menu as shown in main.fs + let subRightClick dispatch = + Browser.Dom.document.addEventListener("contextmenu", unbox (fun (e:Browser.Types.MouseEvent) -> + e.preventDefault() + //printfn "Context Menu listener sending to main..." + dispatch (ContextMenuAction e))) + + + let subContextMenuCommand dispatch = + renderer.ipcRenderer.on("context-menu-command", fun ev args -> + let arg:string = unbox args |> Array.map string |> String.concat "" + printfn "%s" arg + match arg.Split [|','|] |> Array.toList with + | [ menuType ; item ] -> + //printfn "%A" $"Renderer context menu callback: {menuType} --> {item}" + dispatch <| ContextMenuItemClick(menuType,item,dispatch) + | _ -> printfn "Unexpected callback argument sent from main.") |> ignore + + Cmd.batch [ + Cmd.ofSub subDown + Cmd.ofSub subUp + Cmd.ofSub subRightClick + Cmd.ofSub subContextMenuCommand + ] + + + + + + + + + + +Program.mkProgram init update view' +|> Program.withReactBatched "app" +|> Program.withSubscription attachMenusAndKeyShortcuts +|> Program.withSubscription keyPressListener +|> Program.run diff --git a/src/Renderer/Renderer.fsproj b/src/Renderer/Renderer.fsproj index aeba094dc..0335df55e 100644 --- a/src/Renderer/Renderer.fsproj +++ b/src/Renderer/Renderer.fsproj @@ -103,6 +103,8 @@ + + diff --git a/src/Renderer/UI/DeveloperModeHelpers.fs b/src/Renderer/UI/DeveloperModeHelpers.fs new file mode 100644 index 000000000..97d3efb3d --- /dev/null +++ b/src/Renderer/UI/DeveloperModeHelpers.fs @@ -0,0 +1,671 @@ +module DeveloperModeHelpers + +open EEExtensions +open VerilogTypes +open Fulma +open Fulma.Extensions.Wikiki + +open Fable.React +open Fable.React.Props +open JSHelpers + +open DrawModelType +open CommonTypes +open DrawModelType.SheetT +open DrawModelType.BusWireT +open Optics +open Helpers +open BlockHelpers +open Symbol +open BusWireRoute +open BusWire +open BusWireUpdateHelpers +open ModelType +open BusWireRoutingHelpers +open EEExtensions +open Symbol +open DrawModelType +open DrawModelType.SymbolT +open DrawModelType.SheetT +open BusWireRoute +open BusWireRoutingHelpers.Constants +open Sheet + +// Any functions labelled "INTERIM" are temporary and will be replaced with proper implementations of helpers in another file + + + + +// --------------------------------------------------- // +// DeveloperMode Helpers // +// --------------------------------------------------- // + +/// overlap2DBoxvariant from BlockHelpers. Returns a bounding box of an overlap area between two bounding boxes +// Used in DeveloperModeView +// INTERIM FUNCTION, WILL BE REPLACED WITH PROPER INTERSECT HELPERS +let overlapArea2DBox (bb1: BoundingBox) (bb2: BoundingBox) : BoundingBox option = + let xOverlap = + max + 0.0 + (min (bb1.TopLeft.X + bb1.W) (bb2.TopLeft.X + bb2.W) + - max bb1.TopLeft.X bb2.TopLeft.X) + let yOverlap = + max + 0.0 + (min (bb1.TopLeft.Y + bb1.H) (bb2.TopLeft.Y + bb2.H) + - max bb1.TopLeft.Y bb2.TopLeft.Y) + + if xOverlap > 0.0 && yOverlap > 0.0 then + let overlapTopLeft = + { X = max bb1.TopLeft.X bb2.TopLeft.X; Y = max bb1.TopLeft.Y bb2.TopLeft.Y } + Some { TopLeft = overlapTopLeft; W = xOverlap; H = yOverlap } + else + None + +// -------- Mouse-Sensitive Data------------ // +/// function that returns the an string ID with extra formatting of a hovered wire, symbol, or ports +let findHoveredID (pos: XYPos) (model: SheetT.Model) = + let dummySymbolId: ComponentId = ComponentId "dummy" + // we add a 'dummy symbol' to the model to represent the mouse position (cursor) + // solely for calculation purposes, it will not be added to the actual model + // for convenience, we let dummy symbol be 30x30, equal to a Not gate size + let h, w = 30.0, 30.0 + let mouseComponentDummy = + { Id = "dummy" + Type = Not + Label = "dummy" + InputPorts = List.empty + OutputPorts = List.empty + X = pos.X - float w / 2.0 + Y = pos.Y - float h / 2.0 + H = float h + W = float w + SymbolInfo = None } + + // create a mouse dummy symbol, find its bounding box, add it to a dummy model + let mouseSymbolDummy: Symbol = + { (createNewSymbol [] pos NotConnected "" White) with + Component = mouseComponentDummy } + + // Lens to get and set bounding boxes in model + let boundingBoxes_ = + Lens.create (fun m -> m.BoundingBoxes) (fun bb m -> { m with BoundingBoxes = bb }) + + // create a dummy model with the mouse dummy symbol + let dummyModel = + model + |> Optic.set (SheetT.symbols_) (Map.add dummySymbolId mouseSymbolDummy model.Wire.Symbol.Symbols) + // SheetUpdateHelpers has not implemented updateBoundingBoxes yet on master + |> Optic.set boundingBoxes_ (Symbol.getBoundingBoxes model.Wire.Symbol) + |> Optic.map symbols_ (Map.map (fun _ sym -> Symbol.calcLabelBoundingBox sym)) + // we calculate the bounding box of the mouse + let mouseBoundingBox = getSymbolBoundingBox mouseSymbolDummy + + // inspired by SheetBeautifyD1's findAllBoundingBoxesOfSymIntersections + let intersectingWiresInfo = + dummyModel.Wire.Wires + |> Map.values + // findWireSymbolIntersections returns a list of bounding boxes of symbols intersected by wire. + // we find the wires that have a boundingBox in their intersection list that contains our mouseBoundingBox + // we might get more than one wire – so get a list + + |> Seq.map (fun wire -> (wire, (findWireSymbolIntersections dummyModel.Wire wire))) + |> Seq.choose (fun (wire, bboxes) -> + if + bboxes + |> List.exists (fun box -> + + // findWireSymbolIntersections returns bounding boxes that have been enlarged with minWireSeparation + // we correct this + let correctedBox = + { W = box.W - minWireSeparation * 2. + H = box.H - minWireSeparation * 2. + TopLeft = + box.TopLeft + |> updatePos Right_ minWireSeparation + |> updatePos Down_ minWireSeparation } + mouseBoundingBox =~ correctedBox) + then + Some(wire.WId.ToString()) + + else + None) + |> Seq.toList + |> List.tryHead + + // inspired by SheetBeautifyD1's findAllBoundingBoxesOfSymIntersections + let intersectingSymbolInfo = + model.BoundingBoxes + |> Map.toList + // get all boundingBoxes in model not equal to symbolBoundingBox, see if they overlap with symbolBoundingBox, if yes, return compId + |> List.filter (fun (compId, box) -> not (box =~ mouseBoundingBox)) + |> List.choose (fun (compId, box) -> + match (overlapArea2DBox mouseBoundingBox box) with + | Some area -> Some(compId.ToString()) + | None -> None) + |> List.tryHead + + // inpisred by Sheet.mouseOn + // priority: check for mouse over ports first, then symbols, then wires + // the code for checking for mouse over ports is the same as in Sheet.mouseOn + // otherwise symbol and wire mouseover is calculated based on intersection with mouseBoundingBox + match intersectingWiresInfo, intersectingSymbolInfo with + | _, Some symbolId -> + let inputPorts, outputPorts = + Symbol.getPortLocations model.Wire.Symbol [ ComponentId symbolId ] + |> fun (x, y) -> Map.toList x, Map.toList y + match mouseOnPort inputPorts pos 2.5 with + | Some(portId, portLoc) -> "InputPort: ", portId.ToString() + | None -> + match mouseOnPort outputPorts pos 2.5 with + | Some(portId, portLoc) -> "OutputPort: ", portId.ToString() + | None -> "Symbol: ", symbolId.ToString() + | Some wireId, _ -> "Wire: ", wireId.ToString() + | _ -> "Component: ", "Nothing Selected" + + +//-----------Symbols-----------// + +// A helper printing function that returns a string of the symbol's component type description +let getComponentTypeDescrFromSym (symbol : SymbolT.Symbol) = + match symbol.Component.Type with + | Input1 _ -> "Input1" + | Output _ -> "Output" + | Viewer _ -> "Viewer" + | IOLabel -> "IOLabel" + | NotConnected -> "NotConnected" + | BusCompare1 _ -> "BusCompare1" + | BusSelection _ -> "BusSelection" + | Constant1 _ -> "Constant1" + | Not -> "Not" + | Decode4 -> "Decode4" + | GateN _ -> "GateN" + | Mux2 -> "Mux2" + | Mux4 -> "Mux4" + | Mux8 -> "Mux8" + | Demux2 -> "Demux2" + | Demux4 -> "Demux4" + | Demux8 -> "Demux8" + | NbitsAdder _ -> "NbitsAdder" + | NbitsAdderNoCin _ -> "NbitsAdderNoCin" + | NbitsAdderNoCout _ -> "NbitsAdderNoCout" + | NbitsAdderNoCinCout _ -> "NbitsAdderNoCinCout" + | NbitsXor _ -> "NbitsXor" + | NbitsAnd _ -> "NbitsAnd" + | NbitsNot _ -> "NbitsNot" + | NbitsOr _ -> "NbitsOr" + | NbitSpreader _ -> "NbitSpreader" + | Custom customDetails -> $"Custom {customDetails.Name.ToUpper()}" + | MergeWires -> "MergeWires" + | SplitWire _ -> "SplitWire" + | MergeN _ -> "MergeN" + | SplitN _ -> "SplitN" + | DFF -> "DFF" + | DFFE -> "DFFE" + | Register _ -> "Register" + | RegisterE _ -> "RegisterE" + | Counter _ -> "Counter" + | CounterNoLoad _ -> "CounterNoLoad" + | CounterNoEnable _ -> "CounterNoEnable" + | CounterNoEnableLoad _ -> "CounterNoEnableLoad" + | AsyncROM1 _ -> "AsyncROM1" + | ROM1 _ -> "ROM1" + | RAM1 _ -> "RAM1" + | AsyncRAM1 _ -> "Async RAM" + | AsyncROM _ -> "AsyncROM" + | ROM _ -> "ROM" + | RAM _ -> "RAM" + | Shift _ -> "Shift" + | BusCompare _ -> "BusCompare" + | Input _ -> "Input" + | Constant _ -> "Constant" + +/// Function to programmatically generate a html table from PortMaps.Order +let createTableFromPortMapsOrder (map: Map) = + Table.table + [] + (map + |> Map.toList + |> List.map (fun (edge, strList) -> + tr + [] + [ td [ Style [ FontWeight "Bold" ] ] [ str (edge.ToString()) ] + td + [] + (strList + |> List.collect (fun s -> [ code [] [ str ("• " + s) ]; br [] ])) ])) + +/// Function to programmatically generate a html table from a Map PortMaps.Oritentation +let createTableFromPorts (portsMap: Map) (symbol: Symbol) = + let referencePortTable = + // get a list of ports from the selected component. more efficient to search smaller list + // than looking of ports in model.Sheet.Wire.Symbol.Symbols + symbol.Component.InputPorts + @ symbol.Component.OutputPorts + |> List.map (fun port -> port.Id, port) + |> Map.ofList + let portDetailMap = + portsMap + |> Map.map (fun key _ -> Map.tryFind key referencePortTable) + |> Map.filter (fun _ value -> value.IsSome) + |> Map.map (fun _ value -> value.Value) + let tableRows = + portDetailMap + |> Map.toList + |> List.sortBy (fun (_,port) -> (port.PortType, port.PortNumber)) + |> List.map (fun (key, port) -> + tr + [] + [ td [] [ code [] [ str port.Id ] ] + td + [] + [ str ( + match port.PortNumber with + | Some num -> num.ToString() + | None -> "N/A" + ) ] + td + [] + [ str ( + match port.PortType with + | CommonTypes.PortType.Input -> "In" + | CommonTypes.PortType.Output -> "Out" + ) ] + td [] [ code [] [ str port.HostId ] ] ]) + Table.table + [] + [ tr + [] + [ th [] [ str "Port Id" ] + th [] [ str "No." ] + th [] [ str "I/O" ] + th [] [ str "Host Id" ] ] + yield! tableRows ] + + + +//---------- Wire ---------// + + +/// Function to programmatically generate a html table from a list of wire segments +let createTableFromASegments (segments: ASegment list) = + Table.table + [] + [ tr + [] + [ th [] [ str "Len" ] + th [] [ str "Start" ] + th [] [ str "End" ] + th [] [ str "Drag?" ] + th [] [ str "Route?" ] ] + yield! + segments + |> List.map (fun seg -> + tr + [] + [ td [] [ str (sprintf "%.1f" seg.Segment.Length) ] + td [] [ str (sprintf "%.1f, %.1f" seg.Start.X seg.Start.Y) ] + td [] [ str (sprintf "%.1f, %.1f" seg.End.X seg.End.Y) ] + + td + [] + [ str ( + if seg.Segment.Draggable then + "T" + else + "F" + ) ] + td + [] + [ str ( + match seg.Segment.Mode with + | Manual -> "M" + | Auto -> "A" + ) ] ]) ] + + + + + + + + +// --------------------------------------------------- // +// Constants // +// --------------------------------------------------- // + +module Constants = + /// Constant that decides if a wire is classified as almost-straight, if its longest segment in the minority direction is shorter than this length + let bucketSpacing = 0.1 + +open Constants + +//-----------------------------------SegmentHelpers Submodule-----------------------------------// + +// INTERIM MODULE, WILL BE REPLACED WITH PROPER INTERSECT HELPERS +/// Helpers to work with visual segments and nets +/// Includes functions to remove overlapping same-net segments +/// We can assume different-net segments never overlap. +module SegmentHelpers = + + /// The visible segments of a wire, as a list of vectors, from source end to target end. + /// Note that in a wire with n segments a zero length (invisible) segment at any index [1..n-2] is allowed + /// which if present causes the two segments on either side of it to coalesce into a single visible segment. + /// A wire can have any number of visible segments - even 1. + let visibleSegments (wId: ConnectionId) (model: SheetT.Model) : XYPos list = + + let wire = model.Wire.Wires[wId] // get wire from model + + /// helper to match even and odd integers in patterns (active pattern) + let (|IsEven|IsOdd|) (n: int) = + match n % 2 with + | 0 -> IsEven + | _ -> IsOdd + + /// Convert seg into its XY Vector (from start to end of segment). + /// index must be the index of seg in its containing wire. + let getSegmentVector (index: int) (seg: BusWireT.Segment) = + // The implicit horizontal or vertical direction of a segment is determined by + // its index in the list of wire segments and the wire initial direction + match index, wire.InitialOrientation with + | IsEven, BusWireT.Vertical + | IsOdd, BusWireT.Horizontal -> { X = 0.; Y = seg.Length } + | IsEven, BusWireT.Horizontal + | IsOdd, BusWireT.Vertical -> { X = seg.Length; Y = 0. } + + /// Return the list of segment vectors with 3 vectors coalesced into one visible equivalent + /// wherever this is possible + let rec coalesce (segVecs: XYPos list) = + match List.tryFindIndex (fun segVec -> segVec =~ XYPos.zero) segVecs[1 .. segVecs.Length - 2] with + | Some zeroVecIndex -> + let index = zeroVecIndex + 1 // base index as it should be on full segVecs + segVecs[0 .. index - 2] + @ [ segVecs[index - 1] + segVecs[index + 1] ] + @ segVecs[index + 2 .. segVecs.Length - 1] + |> coalesce + | None -> segVecs + + wire.Segments + |> List.mapi getSegmentVector + |> coalesce + + (* These functions make ASSUMPTIONS about the wires they are used on: + - Distinct net segments never overlap + - Same-net segments overlap from source onwards and therefore overlapping segments + must have same start position + - Overlap determination may very occasionally fail, so that overlapped + wires are seen as not overlapped. This allows a much faster overlap check + *) + + open BusWireT // so that Orientation D.U. members do not need qualification + + /// Input must be a pair of visula segment vertices (start, end). + /// Returns segment orientation + let visSegOrientation ((vSegStart, vSegEnd): XYPos * XYPos) = + match abs (vSegStart.X - vSegEnd.X) > abs (vSegStart.Y - vSegEnd.Y) with + | true -> Horizontal + | false -> Vertical + + /// print a visual segment in an easy-toread form + let pvs (seg: XYPos * XYPos) = + let ori = visSegOrientation seg + let startS = fst seg + let endS = snd seg + let c1, cs1, c2, cs2, c3, cs3 = + match ori with + | Vertical -> startS.X, "X", startS.Y, "Y", endS.Y, "Y" + | Horizontal -> startS.Y, "Y", startS.X, "X", endS.X, "X" + $"{ori}:{int c1}{cs1}:({int c2}{cs2}-{int c3}{cs3}) {int <| euclideanDistance startS endS}-" + + /// visible segments in a wire as a pair (start,end) of vertices. + /// start is the segment end nearest the wire Source. + let visibleSegsWithVertices (wire: BusWireT.Wire) (model: SheetT.Model) = + (wire.StartPos, visibleSegments wire.WId model) + ||> List.scan (fun startP segV -> startP + segV) + |> List.pairwise + + /// Filter visSegs so that if they overlap with common start only the longest is kept. + /// ASSUMPTION: in a connected Net this will remove all overlaps + let distinctVisSegs (considerEndSeg: bool) (visSegs: (XYPos * XYPos) list) = + /// convert float to integer buckt number + let pixBucket (pixel: float) = int (pixel / Constants.bucketSpacing) + + /// convert XYPos to pair of bucket numbers + let posBucket (pos: XYPos) = pixBucket pos.X, pixBucket pos.Y + + visSegs + // first sort segments so longest (which we want to keep) are first + |> List.sortByDescending (fun (startOfSeg, endOfSeg) -> euclideanDistance startOfSeg endOfSeg) + // then discard duplicates (the later = shorter ones will be discarded) + // Two segments are judged the same if X & y starting coordinates map to the same "buckets" + // This will very rarely mean that very close but not identical position segments are viewed as different + |> List.distinctBy (fun ((startOfSeg, endOfSeg) as vSeg) -> + if considerEndSeg then + ((posBucket startOfSeg), (Some(posBucket endOfSeg)), visSegOrientation vSeg) + else + ((posBucket startOfSeg), None, visSegOrientation vSeg)) + + /// Filter visSegs so that if they overlap with common start only the longest is kept. + /// More accurate version of distinctVisSegs. + /// Use if the accuracy is needed. + let distinctVisSegsPrecision (visSegs: (XYPos * XYPos) list) = + // This implementation clusters the segments, so cannot go wrong + // It still uses the assumption that overlapped segments have common start position. + // Without that, the code is slower and longer + + /// Turn segs into a distinctSegs list, losing shorter overlapped segments. + /// All of segs must be the same orientation. + let clusterSegments segs = + + /// Add a segment to distinctSegs unless it overlaps. + /// In that case replace seg in distinctSegs if seg is longer than the segment it overlaps. + /// If seg overlaps and is shorter, there is no change to distinctSegs. + /// seg and all segments in distinctSegs must have same orientation. + let addOrientedSegmentToClusters (distinctSegs: (XYPos * XYPos) list) (seg: XYPos * XYPos) = + let len (seg: XYPos * XYPos) = euclideanDistance (fst seg) (snd seg) + let segStart = fst seg + distinctSegs + |> List.tryFindIndex (fun dSeg -> euclideanDistance (fst dSeg) segStart < Constants.bucketSpacing / 2.) + |> function + | Some index when len distinctSegs[index] < len seg -> List.updateAt index seg distinctSegs + | Some index -> distinctSegs // can do nothing + | _ -> seg :: distinctSegs // add seg to the list of distinct (non-overlapped) segments + + ([], segs) + ||> List.fold addOrientedSegmentToClusters + visSegs + |> List.partition (visSegOrientation >> (=) Horizontal) // separate into the two orientations + |> (fun (hSegs, vSegs) -> clusterSegments hSegs @ clusterSegments vSegs) // cluster each orientation separately + + /// input is a list of all the wires in a net. + /// output a list of the visual segments. + /// isDistinct = true => remove overlapping shorter segments + let getVisualSegsFromNetWires (isDistinct: bool) (considerEndSeg: bool) (model: SheetT.Model) netWires = + netWires + |> List.collect (fun wire -> visibleSegsWithVertices wire model) + |> (if isDistinct then + (distinctVisSegs considerEndSeg) + else + id) // comment this to test the preision implementation + // |> (if isDistinct then distinctVisSegsPrecision else id) // uncomment this to test the precision implementation + + /// Returns true if two segments (seg1, seg2) cross in the middle (e.g. not a T junction). + /// Segment crossings very close to being a T junction will be counted. That however should not happen? + /// Seg1, seg2 are represented as pair of start and end vertices + let isProperCrossing (seg1: XYPos * XYPos) (seg2: XYPos * XYPos) = + /// return true if mid is in between a & b, where the order of a & b does not matter. + /// this is an open interval: if mid is close to an endpoint return false. + // rewrite inMiddleOf here with larger tolerance if this is needed. + let isBetween a mid b = + match a > b with + | true -> inMiddleOf b mid a + | false -> inMiddleOf a mid b + + let properCrossingHV (hSeg: XYPos * XYPos) (vSeg: XYPos * XYPos) = + let startH, endH = hSeg + let startV, endV = vSeg + isBetween startH.X startV.X endH.X + && isBetween startV.Y startH.Y endV.Y + + match visSegOrientation seg1, visSegOrientation seg2 with + | BusWireT.Orientation.Horizontal, Vertical -> properCrossingHV seg1 seg2 + | Vertical, Horizontal -> properCrossingHV seg2 seg1 + | _ -> false + + /// visible segments in a Net defined as a pair (start,end) of vertices. + /// source: the source port driving the Net + /// start is the segment end nearest the wire Source. + /// isDistinct = true => filter visible segments so they do not overlap + /// where segments overlap only the longest is taken + /// ASSUMPTION: all overlaps are on segments with same starting point + let visibleSegsInNetWithVertices (isDistinct: bool) (source: OutputPortId) (model: SheetT.Model) = + let wModel = model.Wire + let wires = wModel.Wires + let netWires = + wires + |> Map.filter (fun wid netWire -> netWire.OutputPort = source) // source port is same as wire + |> Map.toList + |> List.map snd + + netWires + |> getVisualSegsFromNetWires isDistinct false model + + /// return a list of all the wire Nets in the model + /// Each element has form (source port Id, list of wires driven by port) + let allWireNets (model: SheetT.Model) = + model.Wire.Wires + |> Map.values + |> Array.toList + |> List.groupBy (fun wire -> wire.OutputPort) + + /// return a lits of all the distinct visible segments + /// visible segments in a Net are defined as a pair (start,end) of vertices. + /// Filter visible segments so they do not overlap + /// where segments overlap only the longest is taken + /// ASSUMPTION: all overlaps are on segments with same starting point + let distinctVisibleSegsInNet = visibleSegsInNetWithVertices true + +//--------------------------------end of SegmentHelpers----------------------------------// + + + + + +// --------------------------------------------------- // +// Professor's T1-T6 (tested and fixed) // +// --------------------------------------------------- // +// INTERIM FUNCTIONS, WILL HAVE TO BE PORTED TO A PROPER HELPER FILE +open SegmentHelpers + +//T1 R +/// Counts the number of pairs of symbols that intersect each other in the sheet. +/// uses sheet Model bounding boxes. +let numOfIntersectedSymPairs (sheet: SheetT.Model) = + let boxes = Map.toList sheet.BoundingBoxes + List.allPairs boxes boxes + |> List.sumBy (function + | ((id1, _), (id2, _)) when id1 <= id2 -> 0 + | ((_, box1), (_, box2)) when BlockHelpers.overlap2DBox box1 box2 -> 1 + | _ -> 0) + +//T2 R +/// The Number of distinct wire visible segments that intersect with one or more symbols in the sheet. +/// Counts each such segment even if they overlap (which is not likely) +/// assumes that within one wire, at most one segment crosses a symbol boundary +/// although this is not always true, it is fine for a metric. +let numOfIntersectSegSym (model: SheetT.Model) : int = + let wModel = model.Wire + let allWires = model.Wire.Wires |> Map.values + allWires + |> Array.map (findWireSymbolIntersections wModel) + |> Array.sumBy (function + | [] -> 0 + | _ -> 1) + +// T3R +/// The number of pairs of distinct visible wire segments that cross each other at right angles in a sheet. +/// Returns the number right angle intersections between wire segments. +/// Does not include crossings that are "T junction" +/// counts segments that overlap only once +/// ASSUMPTION: overlapping segments are in same Net and have same starting point. +let numOfWireRightAngleCrossings (model: SheetT.Model) = + + let nets = allWireNets model + let distinctSegs = + nets + |> List.collect (fun (_, net) -> getVisualSegsFromNetWires true false model net) + List.allPairs distinctSegs distinctSegs + |> List.filter (fun (seg1, seg2) -> seg1 > seg2 && isProperCrossing seg1 seg2) + |> List.length + +//T4 R +/// Sum the wiring length of all wires in the sheet, only counting once +/// when N wire segments of the same-net are overlapping. +/// Returns the total visible wiring segment length over the whole sheet. +/// ASSUMPTION: as in SegmentHelpers +let calcVisWireLength (model: SheetT.Model) : float = + allWireNets model + |> List.collect (fun (_, net) -> getVisualSegsFromNetWires true false model net) + |> List.sumBy (fun (startP, endP) -> euclideanDistance startP endP) + +// T5 R +/// Counts the visible wire right-angles (bends) over the entire sheet. +/// Where same-net wires overlap a bend is counted only once +/// Returns the number of visible wire right-angles. +/// ASSUMPTIONS: right-angles come from two adjacent visible segments +/// ASSUMPTION: segment overlaps as SegmentHelpers +let numOfVisRightAngles (model: SheetT.Model) : int = + let nets = allWireNets model + let numWires = + nets + |> List.sumBy (fun (source, wires) -> wires.Length) + let distinctSegs = + nets + |> List.collect (fun (_, net) -> getVisualSegsFromNetWires true true model net) + // every visual segment => right-angle bend except for the first (or last) in a wire + distinctSegs.Length - numWires + +//T6 R +/// Returns the retracing segments, and those which intersect symbols. +/// a segment seg is retracing if the segment before it is zero-length and +/// the segment two segments before has opposite sign length +let findRetracingSegments (model: SheetT.Model) = + /// Return any segemnts in the wire which are retracing. + let getRetracingSegments (segs: BusWireT.ASegment list) = + /// the two segments go in opposite directions so retrace if separted by zero segmnet + let hasOppositeDir (seg1: BusWireT.ASegment) (seg2: BusWireT.ASegment) = + System.Math.Sign seg1.Segment.Length + <> System.Math.Sign seg2.Segment.Length + segs[2 .. segs.Length - 1] // take all but first two segments - those cannot retrace + |> List.mapi (fun n seg -> n + 2, seg) // index (n+2) is correct for lookup in segs + |> List.filter (fun (n, seg) -> + segs[n - 1].IsZero + && hasOppositeDir segs[n - 2] seg) + |> List.map snd + + /// list of all the segments that are retracing + let retracingSegs = + model.Wire.Wires + |> Map.values + |> Array.toList + |> List.collect (getAbsSegments >> getRetracingSegments) + + /// list of all the symbol bounding boxes from sheet model + let symbolBoundingBoxes = + model.BoundingBoxes + |> Map.toList + |> List.map (fun (_, box) -> box) + + /// return true if the segments intersects any symbol + let checkSegIntersectsAnySymbol (aSeg: BusWireT.ASegment) = + symbolBoundingBoxes + |> List.exists (fun box -> + segmentIntersectsBoundingBox box aSeg.Start aSeg.End + |> Option.isSome) + + let retracingSegsInsideSymbol = + retracingSegs + |> List.filter checkSegIntersectsAnySymbol + + {| RetraceSegs = retracingSegs + RetraceSegsInSymbol = retracingSegsInsideSymbol |} diff --git a/src/Renderer/UI/DeveloperModeView.fs b/src/Renderer/UI/DeveloperModeView.fs new file mode 100644 index 000000000..49f90f89f --- /dev/null +++ b/src/Renderer/UI/DeveloperModeView.fs @@ -0,0 +1,369 @@ +module DeveloperModeView + +open EEExtensions +open VerilogTypes +open Fulma +open Fulma.Extensions.Wikiki + +open Fable.React +open Fable.React.Props + +open JSHelpers +open ModelType +open CommonTypes +open DrawModelType +open DrawModelType.SymbolT +open DrawModelType.BusWireT +open DiagramStyle +open BlockHelpers +open DeveloperModeHelpers +open Symbol +open Optics +open BusWireRoute +open BusWireRoutingHelpers.Constants +open BusWireRoutingHelpers +open Sheet +open DrawModelType.SheetT + + + +(* +STRUCTURE +1. mouseSensitiveDataSection + a. Mouse Position + b. Hovered Component Data +2. sheetStatsMenu + a. Counters + b. Hold/Unhold Button + +// If a symbol is highlighted: +3. Symbol +4. Ports +5. PortMaps + +// If a wire is highlighted: +3. Wire +4. Wire Segments +*) + + +/// Top Level function for developer mode (tdc21) +let developerModeView (model: ModelType.Model) dispatch = +// --------------------------------------------------- // +// Counters // +// Feel free to modify `counterItems` as needed! // +// --------------------------------------------------- // + + /// Contains a record of a counter's display name, tooltip description, and value + /// A counter is a React element for a function that takes in a SheetT.Model and outputs a string/int/float + /// They output useful information about the sheet + let counterItems = + [ + {|DisplayName="T1 Sym-Sym Intersections" ; + ToolTipDescription = "Counts the number of symbols intersecting other \nsymbols on the sheet."; + Value=(numOfIntersectedSymPairs model.Sheet).ToString() |} + {|DisplayName="T2 Seg-Sym Intersections" ; + ToolTipDescription = "Counts the number of visible wire segments \nintersecting on the sheet"; + Value=(numOfIntersectSegSym model.Sheet).ToString() |} + {|DisplayName="T3 Vis-Wire Seg 90º Cross" ; + ToolTipDescription = "Counts the number of visible wire segments that \nintersect at 90 degrees."; + Value=(numOfWireRightAngleCrossings model.Sheet).ToString() |} + {|DisplayName="T4 Sum of Vis-Wire Segs" ; + ToolTipDescription = "Counts the total length of all visible \nwire segments on the sheet.\n\n Assumption: \nOverlapping segments share the same starting net, and may\ndiverge at some point but will not return to overlap."; + Value=(calcVisWireLength model.Sheet).ToString("F2") |} + {|DisplayName="T5 Count Visible R-Angles" ; + ToolTipDescription = "Counts the number of visible right angles \nfound in the wire segments on the sheet."; + Value=(numOfVisRightAngles model.Sheet).ToString() |} + {|DisplayName="T6 RetracingSegments"; + ToolTipDescription = "Counts the number of retracing segments on sheet.\nZero-length segments with non-zero segments on \nboth sides that have lengths of opposite signs lead to a \nwire retracing itself"; + Value=(List.length (findRetracingSegments model.Sheet).RetraceSegsInSymbol).ToString() |} + ] + +// ----------------------------------------------------------------- // +// Mouse Sensitive Data- Updates based on Mouse Position // +// ----------------------------------------------------------------- // + + /// Stores string details of the currently hovered comp to be used in sheetStatsMenu + let hoveredType, hoveredId = findHoveredID model.Sheet.LastMousePos model.Sheet + + /// Stores the mouse position and hovered component data + let mouseSensitiveDataSection = + div + [ Style [ MarginBottom "20px" ] ] + [ strong [] [ str ("Mouse Position: ") ] + br [] + code + [] + [ str ( + (model.Sheet.LastMousePos.X.ToString("F2")) + + ", " + + (model.Sheet.LastMousePos.Y.ToString("F2")) + ) ] + + br [] + strong [] [ str ("Hovered " + hoveredType) ] + br [] + code [] [ str (hoveredId) ] ] + + +// -------------------------------------------- // +// Sheet Stats Menu (sheetStatsMenu) // +// -------------------------------------------- // + + /// Contains the mouse position, hovered comp data, and the counters + let sheetStatsMenu = + /// Selecting the (hold/unhold) button shows/hides the current sheet counter stats to a column on sheetstats. Used for comparison purposes + let holdUnholdButton = + let cachedSheetStats = counterItems |> List.map (fun counterRecord -> counterRecord.Value) + div + [ Style [ Margin "5px 0 10px 0" ] ] + [ Level.level + [] + [ Level.item + [ Level.Item.HasTextCentered ] + [ div + [ Style [ FontSize "14px"; Width "100%"; Border "1.1px solid #555" ] ] + [ Menu.list [] + [ Menu.Item.li + [(Menu.Item.IsActive(model.Tracking)); + Menu.Item.OnClick(fun _ -> + let updatedCachedData = + match model.Tracking with + | true -> None + | false -> Some cachedSheetStats + dispatch (SelectTracking((not model.Tracking), updatedCachedData)) + )] + [ strong [] [ str "Hold/Unhold Values" ] ] + ] + ] + ] + ] + ] + + /// Contains the counters in a html table format + /// A counter is a React element for a function that takes in a SheetT.Model and outputs a string/int/float + /// They output useful information about the sheet + let counters = + let heldColumnText = (if model.HeldCounterValues.IsSome then "Held" else "") + + let firstColumnWidth, secondColumnWidth, thirdColumnWidth = + match model.HeldCounterValues with + | Some _ -> "60%", "20%", "20%" + | None -> "72%", "0%", "28%" + let counterRows = + let combinedItems = + match model.HeldCounterValues with + | Some stats -> List.zip counterItems stats + | None -> List.map (fun item -> (item, "")) counterItems + + combinedItems + |> List.mapi (fun i (entry, stat) -> + let isEven = i % 2 = 0 + let backgroundColor = if isEven then "#eee" else "transparent" + let tooltip = if entry.ToolTipDescription = "" then (Id "no-tooltip") else Tooltip.dataTooltip (str entry.ToolTipDescription) + tr + [] + [ + td [Style [BackgroundColor backgroundColor; Width firstColumnWidth; Padding "3px 1px 3px 7px"; FontSize "13px"; LineHeight "24px"; + Margin 0; BorderTop "1px solid #dbdbdb";BorderBottom "1px solid #dbdbdb" ;FontWeight "600"];] + [ div [Style [ Width "320px" ]; HTMLAttr.ClassName $"{Tooltip.ClassName} has-tooltip-top" ; tooltip] [str(entry.DisplayName)]] + td [Style [BackgroundColor backgroundColor; Width secondColumnWidth; Padding "3px "; Margin 0; BorderTop "1px solid #dbdbdb";BorderBottom "1px solid #dbdbdb";FontWeight "500";]] [str stat] + td [Style [BackgroundColor backgroundColor; Width thirdColumnWidth; Padding "3px "; Margin 0; BorderTop "1px solid #dbdbdb";BorderBottom "1px solid #dbdbdb";FontWeight "500";]] [str(entry.Value)] + ]) + + div [] [ + table + [Style [ Width "100%"; TableLayout "fixed"; BorderCollapse "collapse";]] + [ + tr [] + [ + th [Style [BackgroundColor "#485fc7"; Color "White";Width firstColumnWidth; Padding "3px 1px 3px 7px"; Margin 0; BorderTop "1px solid #dbdbdb";BorderBottom "1px solid #dbdbdb";FontWeight "600"]] + [str "Helper/Counter"]; + th [Style [BackgroundColor "#485fc7"; Color "White";Width secondColumnWidth; Padding "3px 3px"; Margin 0; BorderTop "1px solid #dbdbdb";BorderBottom "1px solid #dbdbdb";FontWeight "600"]] + [str heldColumnText]; + th [Style [BackgroundColor "#485fc7"; Color "White";Width thirdColumnWidth; Padding "3px 10px 3px 3px"; Margin 0; BorderTop "1px solid #dbdbdb";BorderBottom "1px solid #dbdbdb";FontWeight "600"]] + [str "Current"]; + ]; + yield! counterRows + ]] + + + details + [ Open(model.SheetStatsExpanded) ] + [ summary [ menuLabelStyle; OnClick(fun _ -> dispatch (ToggleSheetStats)) ] [ str "Sheet Stats " ] + div + [] + [ + counters + div [HTMLAttr.ClassName $"{Tooltip.ClassName} has-tooltip-bottom";Tooltip.dataTooltip (str "Hold a copy of the existing sheet values in the \ntable ('Held' column) for comparison purposes.\nCurrent values column is always dynamic.")] + [holdUnholdButton] + ] ] + + // ----------------- // + // Symbols // + // ----------------- // + + /// Function to programmatically generate data for a symbol. Includes the symbol's data, its port data, and portmap + let symbolToListItem (model: ModelType.Model) (symbol: Symbol) = + let SymbolTableInfo = + (Table.table + [ Table.IsFullWidth; Table.IsBordered ] + [ tbody + [] + [ tr + [] + [ td [] [ strong [] [ str "Id: " ] ] + td [] [ code [] [ str (symbol.Id.ToString()) ] ] ] + tr + [] + [ td [] [ strong [] [ str "Pos: " ] ] + td + [] + [ str ( + symbol.Pos.X.ToString("F2") + + ", " + + symbol.Pos.Y.ToString("F2") + ) ] ] + tr + [] + [ td [] [ strong [] [ str "Comp. Type: " ] ] + td [] [ code [] [ str (getComponentTypeDescrFromSym symbol) ] ] ] + tr + [] + [ td [] [ strong [] [ str "Comp. Label: " ] ] + td [] [ str (symbol.Component.Label.ToString()) ] ] + tr + [] + [ td [] [ strong [] [ str "Comp. H,W: " ] ] + td + [] + [ str ( + symbol.Component.H.ToString("F2") + + ", " + + symbol.Component.W.ToString("F2") + ) ] ] + tr + [] + [ td [] [ strong [] [ str "STransform: " ] ] + td + [] + [ str ( + "Rotation: " + + symbol.STransform.Rotation.ToString() + ) + br [] + str ("flipped: " + symbol.STransform.flipped.ToString()) ] ] + tr + [] + [ td [] [ strong [] [ str "HScale, VScale: " ] ] + td + [] + [ (match symbol.HScale with + | Some hscale -> str ("HScale: " + hscale.ToString("F2")) + | None -> str "HScale: N/A") + br [] + (match symbol.VScale with + | Some vscale -> str ("VScale: " + vscale.ToString("F2")) + | None -> str "VScale: N/A") ] ] ] ]) + + // expandable menu persists between updates due to the model keeping track of the expanded state. + // this is unlike the Catalogue menu that immediately shuts expandable menu when the user clicks away + [ details + [ Open(model.SymbolInfoTableExpanded) ] + [ summary [ menuLabelStyle; OnClick(fun _ -> dispatch (ToggleSymbolInfoTable)) ] [ str "Symbol " ] + div [] [ SymbolTableInfo ] ] + details + [ Open model.SymbolPortsTableExpanded ] + [ summary [ menuLabelStyle; OnClick(fun _ -> dispatch (ToggleSymbolPortsTable)) ] [ str "Ports" ] + div [] [ (createTableFromPorts symbol.PortMaps.Orientation symbol) ] ] + details + [ Open model.SymbolPortMapsTableExpanded ] + [ summary [ menuLabelStyle; OnClick(fun _ -> dispatch (ToggleSymbolPortMapsTable)) ] [ str "PortMaps" ] + div [] [ (createTableFromPortMapsOrder symbol.PortMaps.Order) ] ] ] + + + // ---------------- // + // Wire // + // ---------------- // + + /// Function to programmatically generate data for a wire. Includes the wire's data and its segments + let wireToListItem (wire: Wire) = + let WireTableInfo = + (Table.table + [ Table.IsFullWidth; Table.IsBordered ] + [ tbody + [] + [ tr + [] + [ td [] [ strong [] [ str "WId: " ] ] + td [] [ code [] [ str (wire.WId.ToString()) ] ] ] + tr + [] + [ td [] [ strong [] [ str "StartPos: " ] ] + td + [] + [ str ( + wire.StartPos.X.ToString("F2") + + ", " + + wire.StartPos.Y.ToString("F2") + ) ] ] + tr + [] + [ td [] [ strong [] [ str "InputPort: " ] ] + td [] [ code [] [ str (wire.InputPort.ToString()) ] ] ] + tr + [] + [ td [] [ strong [] [ str "OutputPort: " ] ] + td [] [ code [] [ str (wire.OutputPort.ToString()) ] ] ] + tr [] [ td [] [ strong [] [ str "Width: " ] ]; td [] [ str (wire.Width.ToString()) ] ] + tr + [] + [ td [] [ strong [] [ str "InitialOrientation: " ] ] + td [] [ str (wire.InitialOrientation.ToString()) ] ] + tr + [] + [ td [] [ strong [] [ str "Length: " ] ] + td [] [ str ((wire.Segments |>List.sumBy (fun seg -> abs(seg.Length))).ToString("F2")) ] ] ] ]) + + + let absSegments = getAbsSegments wire + let WireSegmentsTableInfo = createTableFromASegments absSegments + + [ details + [ Open model.WireTableExpanded ] + [ summary [ menuLabelStyle; OnClick(fun _ -> dispatch (ToggleWireTable)) ] [ str "Wire " ] + div [] [ WireTableInfo ] ] + details + [ Open model.WireSegmentsTableExpanded ] + [ summary [ menuLabelStyle; OnClick(fun _ -> dispatch (ToggleWireSegmentsTable)) ] [ str "Wire Segments" ] + div [] [ WireSegmentsTableInfo ] ] ] + + /// Code taken from the Properties tab. If nothing is selected, a message is displayed. + let viewComponent = + match model.Sheet.SelectedComponents, model.Sheet.SelectedWires with + | [ compId: ComponentId ], [] -> + let comp = SymbolUpdate.extractComponent model.Sheet.Wire.Symbol compId + let symbol: SymbolT.Symbol = model.Sheet.Wire.Symbol.Symbols[compId] + + div [ Key comp.Id ] [ ul [] (symbolToListItem model symbol) ] + | [], [ wireId: ConnectionId ] -> + let wire = model.Sheet.Wire.Wires.[wireId] + div [ Key(wireId.ToString()) ] [ ul [] (wireToListItem wire) ] + | _ -> + match model.CurrentProj with + | Some proj -> + let sheetName = proj.OpenFileName + let sheetLdc = + proj.LoadedComponents + |> List.find (fun ldc -> ldc.Name = sheetName) + let sheetDescription = sheetLdc.Description + + div + [] + [ p [] [ str "Select a component in the diagram to view its attributes." ] + br [] ] + | None -> null + + /// Top level div for the developer mode view + let viewComponentWrapper = div [] [ p [ menuLabelStyle ] []; viewComponent ] + div [ Style [ Margin "-10px 0 20px 0" ] ] ([ mouseSensitiveDataSection; sheetStatsMenu; viewComponentWrapper ]) diff --git a/src/Renderer/UI/MainView.fs b/src/Renderer/UI/MainView.fs index 785594d85..0106b5bc8 100644 --- a/src/Renderer/UI/MainView.fs +++ b/src/Renderer/UI/MainView.fs @@ -14,12 +14,24 @@ open Sheet.SheetInterface open DrawModelType open CommonTypes open PopupHelpers - +open JSHelpers +open DrawModelType +open Browser open Fable.Core open Fable.Core.JsInterop open Browser.Dom +/// Used to filter out-of-sequence OnScroll messages. +/// These could reset scroll to some previous value. +/// Incremented by program UpdateScroll and OnScroll. +let mutable scrollSequence: int = 0 +let mutable rightSelectionDiv:Types.Element option = None + +let writeRightSelectionScroll (scrollPos:XYPos) = + // printf "%s" $"***writing devmode scroll: {scrollPos.X},{scrollPos.Y}" + rightSelectionDiv + |> Option.iter (fun el -> el.scrollLeft <- scrollPos.X; el.scrollTop <- scrollPos.Y) //------------------Buttons overlaid on Draw2D Diagram----------------------------------// @@ -30,20 +42,20 @@ let viewOnDiagramButtons model dispatch = let dispatch = SheetT.KeyPress >> sheetDispatch div [ canvasSmallMenuStyle ] [ - let canvasBut func label = - Button.button [ - Button.Props [ canvasSmallButtonStyle; OnClick func ] + let canvasBut func label = + Button.button [ + Button.Props [ canvasSmallButtonStyle; OnClick func ] Button.Modifiers [ //Modifier.TextWeight TextWeight.Bold Modifier.TextColor IsLight Modifier.BackgroundColor IsSuccess ] - ] + ] [ str label ] - canvasBut (fun _ -> dispatch SheetT.KeyboardMsg.CtrlZ ) "< undo" - canvasBut (fun _ -> dispatch SheetT.KeyboardMsg.CtrlY ) "redo >" - canvasBut (fun _ -> dispatch SheetT.KeyboardMsg.CtrlC ) "copy" - canvasBut (fun _ -> dispatch SheetT.KeyboardMsg.CtrlV ) "paste" + canvasBut (fun _ -> dispatch SheetT.KeyboardMsg.CtrlZ ) "< undo" + canvasBut (fun _ -> dispatch SheetT.KeyboardMsg.CtrlY ) "redo >" + canvasBut (fun _ -> dispatch SheetT.KeyboardMsg.CtrlC ) "copy" + canvasBut (fun _ -> dispatch SheetT.KeyboardMsg.CtrlV ) "paste" ] @@ -122,6 +134,17 @@ let init() = { Pending = [] UIState = None BuildVisible = false + RightSelectionScrollPos = {X = 0; Y = 0} + SettingsMenuExpanded = false + Tracking = false + HeldCounterValues = None + BeautifyMenuExpanded = false + SymbolInfoTableExpanded = true + SymbolPortMapsTableExpanded = true + WireTableExpanded = true + WireSegmentsTableExpanded = true + SymbolPortsTableExpanded = true + SheetStatsExpanded = true } @@ -133,7 +156,7 @@ let makeSelectionChangeMsg (model:Model) (dispatch: Msg -> Unit) (ev: 'a) = let viewSimSubTab canvasState model dispatch = match model.SimSubTabVisible with - | StepSim -> + | StepSim -> div [ Style [Width "90%"; MarginLeft "5%"; MarginTop "15px" ] ] [ Heading.h4 [] [ str "Step Simulation" ] SimulationView.viewSimulation canvasState model dispatch @@ -143,7 +166,7 @@ let viewSimSubTab canvasState model dispatch = Heading.h4 [] [ str "Truth Tables" ] TruthTableView.viewTruthTable canvasState model dispatch ] - | WaveSim -> + | WaveSim -> div [ Style [Width "100%"; Height "calc(100% - 72px)"; MarginTop "15px" ] ] [ viewWaveSim canvasState model dispatch ] @@ -152,10 +175,10 @@ let private viewRightTab canvasState model dispatch = let pane = model.RightPaneTabVisible match pane with | Catalogue | Transition -> - + div [ Style [Width "90%"; MarginLeft "5%"; MarginTop "15px" ; Height "calc(100%-100px)"] ] [ Heading.h4 [] [ str "Catalogue" ] - div [ Style [ MarginBottom "15px" ; Height "100%"; OverflowY OverflowOptions.Auto] ] + div [ Style [ MarginBottom "15px" ; Height "100%"; OverflowY OverflowOptions.Auto] ] [ str "Click on a component to add it to the diagram. Hover on components for details." ] CatalogueView.viewCatalogue model dispatch ] @@ -164,15 +187,26 @@ let private viewRightTab canvasState model dispatch = Heading.h4 [] [ str "Component properties" ] SelectedComponentView.viewSelectedComponent model dispatch ] + | DeveloperMode -> + if debugLevel > 0 then + div + [ Style [ Width "90%"; MarginLeft "5%"; MarginTop "15px" ]; + + ] + [ Heading.h4 [] [ str "Developer Mode" ] + div [ Style [ MarginBottom "15px" ]] [] + DeveloperModeView.developerModeView model dispatch ] + else + div [] [] | Simulation -> - let subtabs = + let subtabs = Tabs.tabs [ Tabs.IsFullWidth; Tabs.IsBoxed; Tabs.CustomClass "rightSectionTabs"; - Tabs.Props [Style [Margin 0] ] ] - [ + Tabs.Props [Style [Margin 0] ] ] + [ Tabs.tab // step simulation subtab [ Tabs.Tab.IsActive (model.SimSubTabVisible = StepSim) ] - [ a [ OnClick (fun _ -> dispatch <| ChangeSimSubTab StepSim ) ] [str "Step Simulation"] ] + [ a [ OnClick (fun _ -> dispatch <| ChangeSimSubTab StepSim ) ] [str "Step Simulation"] ] (Tabs.tab // truth table tab to display truth table for combinational logic [ Tabs.Tab.IsActive (model.SimSubTabVisible = TruthTable) ] @@ -181,8 +215,10 @@ let private viewRightTab canvasState model dispatch = (Tabs.tab // wavesim tab [ Tabs.Tab.IsActive (model.SimSubTabVisible = WaveSim) ] [ a [ OnClick (fun _ -> dispatch <| ChangeSimSubTab WaveSim) ] [str "Wave Simulation"] ]) + + ] - div [ HTMLAttr.Id "RightSelection2"; Style [Height "100%"]] + div [ HTMLAttr.Id "RightSelection2"; Style [Height "100%"]] [ //br [] // Should there be a gap between tabs and subtabs for clarity? subtabs @@ -197,30 +233,30 @@ let private viewRightTab canvasState model dispatch = /// determine whether moving the mouse drags the bar or not let inline setDragMode (modeIsOn:bool) (model:Model) dispatch = - fun (ev: Browser.Types.MouseEvent) -> + fun (ev: Browser.Types.MouseEvent) -> makeSelectionChangeMsg model dispatch ev //printfn "START X=%d, buttons=%d, mode=%A, width=%A, " (int ev.clientX) (int ev.buttons) model.DragMode model.ViewerWidth match modeIsOn, model.DividerDragMode with - | true, DragModeOff -> + | true, DragModeOff -> dispatch <| SetDragMode (DragModeOn (int ev.clientX)) - | false, DragModeOn _ -> + | false, DragModeOn _ -> dispatch <| SetDragMode DragModeOff | _ -> () /// Draggable vertivcal bar used to divide Wavesim window from Diagram window let dividerbar (model:Model) dispatch = - let isDraggable = - model.RightPaneTabVisible = Simulation - && (model.SimSubTabVisible = WaveSim + let isDraggable = + model.RightPaneTabVisible = Simulation + && (model.SimSubTabVisible = WaveSim || model.SimSubTabVisible = TruthTable) - let heightAttr = + let heightAttr = let rightSection = document.getElementById "RightSection" if (isNull rightSection) then Height "100%" else Height "100%" //rightSection.scrollHeight - let variableStyle = + let variableStyle = if isDraggable then [ BackgroundColor "grey" - Cursor "ew-resize" + Cursor "ew-resize" Width Constants.dividerBarWidth ] else [ @@ -235,56 +271,78 @@ let dividerbar (model:Model) dispatch = ] div [ Style <| commonStyle @ variableStyle - OnMouseDown (setDragMode true model dispatch) + OnMouseDown (setDragMode true model dispatch) ] [] let viewRightTabs canvasState model dispatch = /// Hack to avoid scrollbar artifact changing from Simulation to Catalog - /// The problem is that the HTML is bistable - with Y scrollbar on the catalog