diff --git a/src/Renderer/Common/CommonTypes.fs b/src/Renderer/Common/CommonTypes.fs index 8d67f5b56..846a9d8b8 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 @@ -348,6 +348,13 @@ module CommonTypes | Clockwise -> AntiClockwise | _ -> Clockwise + // define this first, then extend later with members to convert to bounding box + type Rectangle = { + TopLeft: XYPos + BottomRight: XYPos + } + + type BoundingBox = { /// Top left corner of the bounding box TopLeft: XYPos @@ -355,8 +362,28 @@ 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.} + member inline this.ToRect = {TopLeft=this.TopLeft; BottomRight=(this.TopLeft + {X=this.W; Y=this.H})} + + /// 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 + + + type Rectangle + with + member this.Centre = (this.TopLeft + this.BottomRight) * 0.5 + member inline this.ToBoundingBox = {TopLeft=this.TopLeft; W=this.BottomRight.X - this.TopLeft.X; H=this.BottomRight.Y - this.TopLeft.Y} + static member inline epsilon = 0.0001 + static member inline (=~)(left: Rectangle, right: Rectangle) = + left.TopLeft =~ right.TopLeft && left.BottomRight =~ right.BottomRight let topLeft_ = Lens.create (fun a -> a.TopLeft) (fun s a -> {a with TopLeft = s}) @@ -365,7 +392,7 @@ module CommonTypes type ScaleAdjustment = | Horizontal | Vertical - + type SymbolInfo = { LabelBoundingBox: BoundingBox option LabelRotation: Rotation option @@ -394,11 +421,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 +437,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 +460,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 +496,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 +518,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 +543,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 +585,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 +706,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 +736,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 +759,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 +772,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 +796,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 +881,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 +893,7 @@ module CommonTypes } - + /// Info saved by Wave Sim. @@ -894,14 +921,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 +944,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 +978,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 +1001,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/Common/DrawHelpers.fs b/src/Renderer/Common/DrawHelpers.fs index 119eca6ce..23960c270 100644 --- a/src/Renderer/Common/DrawHelpers.fs +++ b/src/Renderer/Common/DrawHelpers.fs @@ -23,13 +23,13 @@ type PortLocation = { R: float } -type MouseOp = +type MouseOp = /// button up | Up /// button down | Down /// Move with button up - | Move + | Move /// Move with button Down | Drag @@ -46,7 +46,7 @@ type MouseT = { /// Record to help draw SVG circles type Circle = { /// Radius of the circle - R: float + R: float /// color of outline: default => black color Stroke: string /// width of outline: default => thin @@ -108,7 +108,7 @@ let getTextWidthInPixels (font:Text) (txt:string) = canvasWidthContext.font <- askedFont //printf "Measururing '%s' -> '%s' with txt '%s' - fontSize=%s, sizeInpx = %.2f" askedFont canvasWidthContext.font txt font.FontSize sizeInPx let textMetrics = canvasWidthContext.measureText(txt) - let ms = textMetrics.width + let ms = textMetrics.width ms /// Default line, change this one to create new lines @@ -180,7 +180,7 @@ let uuid():string = System.Guid.NewGuid.ToString() // ----------------------------- SVG Helpers ----------------------------- // -/// Makes a line ReactElement, wildcard inputs as position can be a number or a string +/// Makes a line ReactElement, wildcard inputs as position can be a number or a string let makeLine (x1: 'a) (y1: 'b) (x2: 'c) (y2: 'd) (lineParameters: Line) = line [ X1 x1 @@ -248,8 +248,8 @@ let makePath (startingPoint: XYPos) (startingControlPoint: XYPos) (endingControl SVGAttr.StrokeLinecap pathParameters.StrokeLinecap SVGAttr.Fill pathParameters.Fill ] [] - -/// Makes a polygon ReactElement, points are to be given as a correctly formatted SVGAttr.Points string + +/// Makes a polygon ReactElement, points are to be given as a correctly formatted SVGAttr.Points string let makePolygon (points: string) (polygonParameters: Polygon) = polygon [ SVGAttr.Points points @@ -258,12 +258,12 @@ let makePolygon (points: string) (polygonParameters: Polygon) = SVGAttr.Fill polygonParameters.Fill SVGAttr.FillOpacity polygonParameters.FillOpacity ] [] - + /// Makes a circle ReactElement let makeCircle (centreX: float) (centreY: float) (circleParameters: Circle) = circle - [ + [ Cx centreX Cy centreY R circleParameters.R @@ -272,12 +272,12 @@ let makeCircle (centreX: float) (centreY: float) (circleParameters: Circle) = SVGAttr.Stroke circleParameters.Stroke SVGAttr.StrokeWidth circleParameters.StrokeWidth ] [] - + /// Makes a text ReactElement let makeText (posX: float) (posY: float) (displayedText: string) (textParameters: Text) = text [ - X posX; - Y posY; + X posX; + Y posY; Style [ TextAnchor textParameters.TextAnchor DominantBaseline textParameters.DominantBaseline @@ -285,7 +285,7 @@ let makeText (posX: float) (posY: float) (displayedText: string) (textParameters FontSize textParameters.FontSize FontFamily textParameters.FontFamily Fill textParameters.Fill - UserSelect textParameters.UserSelect + UserSelect textParameters.UserSelect ] ] [str <| sprintf "%s" (displayedText)] @@ -293,15 +293,15 @@ let makeText (posX: float) (posY: float) (displayedText: string) (textParameters /// Dy parameter determines line spacing let makeTwoLinesOfText (posX: float) (posY: float) (line1: string) (line2: string) (textParameters: Text) = text [ - X posX; - Y posY; + X posX; + Y posY; Style [ TextAnchor textParameters.TextAnchor DominantBaseline textParameters.DominantBaseline FontWeight textParameters.FontWeight FontSize textParameters.FontSize Fill textParameters.Fill - UserSelect textParameters.UserSelect + UserSelect textParameters.UserSelect ] ] [tspan [] [str line1]; tspan [Dy "1.2em"] [str line2] ] @@ -317,7 +317,7 @@ let getColorString (col: CommonTypes.HighLightColor) = /// Calculates if two bounding boxes intersect by comparing corner coordinates of each box let boxesIntersect (box1: BoundingBox) (box2: BoundingBox) = // Requires min and max since H & W can be negative, i.e. we don't know which corner is which automatically - // Boxes intersect if there is overlap in both x and y coordinates + // Boxes intersect if there is overlap in both x and y coordinates min box1.TopLeft.X (box1.TopLeft.X + box1.W) < max box2.TopLeft.X (box2.TopLeft.X + box2.W) && min box2.TopLeft.X (box2.TopLeft.X + box2.W) < max box1.TopLeft.X (box1.TopLeft.X + box1.W) && min box1.TopLeft.Y (box1.TopLeft.Y + box1.H) < max box2.TopLeft.Y (box2.TopLeft.Y + box2.H) @@ -325,5 +325,5 @@ let boxesIntersect (box1: BoundingBox) (box2: BoundingBox) = - + diff --git a/src/Renderer/Common/EEExtensions.fs b/src/Renderer/Common/EEExtensions.fs index 1499d7d8b..61f72ff95 100644 --- a/src/Renderer/Common/EEExtensions.fs +++ b/src/Renderer/Common/EEExtensions.fs @@ -1,351 +1,381 @@ -(* - This module contains some general purpose library functions -*) - -namespace EEExtensions -/// CHANGELIST -/// July 2018: add String.regexMatchGroups, correct documentation for regexMatch - -/// Miscellaneous extensions to core F# library functions -/// Additions to Char, String, Map - - -/// various functions that exist in normal F# but cannot work in fable -module FableReplacements = - let optionMap2 f v1 v2 = match v1, v2 with - | Some v1, Some v2 -> Some (f v1 v2) - | _ -> None - - let listChunkBySize chunkSize l = - let rec listChunkBySize' state chunksLeft itemsRemaining = - match chunksLeft, itemsRemaining with - | _, [] -> state - | 0, _ -> listChunkBySize' ([] :: state) chunkSize itemsRemaining - | _, nextItem::itemsTail -> listChunkBySize' ((nextItem :: List.head state) :: (List.tail state)) (chunksLeft - 1) itemsTail - - match l with - | [] -> [] - | _ -> listChunkBySize' [] 0 l |> List.map List.rev |> List.rev - - let hexToString (x : uint32) = - let rec loop str = - function - | 0u -> str - | num -> loop ((sprintf "%X" (num % 16u)) + str) (num / 16u) - match x with - | 0u -> "0" - | _ -> loop "" x - -// Following char method to convert to integer is partly based on code found on -// http://www.fssnip.net/25/title/Hex-encode-decode -[] -[] -module Char = - - [] - let inline IsLetterOrDigitOrUnderscore(ch: char): bool = - System.Char.IsLetterOrDigit ch || ch = '_' - - [] - let inline toInt(ch: char): int = - match ch with - | c when c >= '0' && c <= '9' -> int c - int '0' - | c when c >= 'a' && c <= 'f' -> (int c - int 'a') + 10 - | c when c >= 'A' && c <= 'F' -> (int c - int 'A') + 10 - | _ -> failwithf "What ? Error while converting character to digit" - -[] -[] -module String = - - open System - - [] - let inline ofChar( ch: char): string = [| ch |] |> Seq.ofArray |> System.String.Concat - - [] - let inline ofSeq (chars: char seq) : string = System.String.Concat chars - - [] - let inline toSeq (str: string) : char seq = str :> char seq - - [] - let inline ofList (chars: char list) = chars |> Seq.ofList |> System.String.Concat - - - [] - let inline ofArray (chars: char array) = chars |> Seq.ofArray |> System.String.Concat - - [] - let inline toList (str: string): char list = str |> List.ofSeq - - [] - let inline toArray (str: string): char array = str |> Array.ofSeq - - /// splits text into its array of non-whitepace strings separated by whitespace - [] - let splitOnWhitespace (text:string): string array = - text.Split( ([||]: char array) , System.StringSplitOptions.RemoveEmptyEntries) - - let [] DefaultComparison = StringComparison.Ordinal - let inline emptyIfNull str = - match str with - | null -> String.Empty - | _ -> str - /// Concatenate a sequence of strings - /// Using sep as separator - [] - let concat sep (strings : seq) = - String.Join(sep, strings) - - [] - let length (str:string) = - let str = emptyIfNull str - str.Length - - /// True if str contains value - [] - let contains (value:string) (str:string) = - str.Contains(value) - - [] - let compare (strB:string) (strA:string) = - String.Compare(strA, strB, DefaultComparison) - - /// True if str ends with value - [] - let endsWith (value:string) (str:string) = - str.EndsWith(value, DefaultComparison) - /// See String.Equals - [] - let equals (comparisonType:StringComparison) (value:string) (str:string) = - str.Equals(value, comparisonType) - - let inline checkIndex func (comparisonType:StringComparison) value = - let index = func(value, comparisonType) - if index = -1 then None - else Some index - - /// Replace all occurences of oldChar by newchar - [] - let replaceChar (oldChar:char) (newChar:char) (str:string) = - str.Replace(oldChar, newChar) - - /// Replace all occurences of oldValue by newValue - [] - let replace (oldValue:string) (newValue:string) (str:string) = - str.Replace(oldValue, newValue) - - /// Split str at all of separator array elements - /// Return array of strings - /// Adjacent separators generate empty strings - [] - let split (separator:char array) (str:string) = - str.Split(separator, StringSplitOptions.None) - - /// Split str at all of separator array elements - /// Return array of strings - /// Adjacent separators do not generate strings - [] - let splitRemoveEmptyEntries (separator:char array) (str:string) = - str.Split(separator, StringSplitOptions.RemoveEmptyEntries) - - /// Split str at all of separator string array elements - /// Return array of strings - /// Adjacent separators generate empty strings - [] - let splitString (separator:string array) (str:string) = - str.Split(separator, StringSplitOptions.None) - /// Split str at all of separator string array elements - /// Return array of strings - /// Adjacent separators do not generate strings - [] - let splitStringRemoveEmptyEntries (separator:string array) (str:string) = - str.Split(separator, StringSplitOptions.RemoveEmptyEntries) - - /// Return true if str starts with value - [] - let startsWith (value:string) (str:string) = - str.StartsWith(value, DefaultComparison) - - /// Return true if str starts with a letter - [] - let startsWithLetter (str:string) = - str <> "" && System.Char.IsLetter str[0] - - - /// Return substring of str at startIndex of length chars - /// Throw ArgumentOutOfRange exception if any part of - /// selected string lies outside str. - [] - let substringLength (startIndex:int) (length: int) (str:string) = - str.Substring(startIndex, length) - /// Return str from startIndex till end - /// Throw ArgumentOutOfRange exception if startWith - /// lies outside str - [] - let substring (startIndex:int) (str:string) = - str.Substring(startIndex) - - [] - let toLower(str:string) = - str.ToLowerInvariant() - - [] - let toUpper(str:string) = - str.ToUpperInvariant() - /// Remove all leading and training whitespace - [] - let trim(str:string) = - str.Trim() - /// Remove all leading and trailing chars in trimChars - [] - let trimChars (trimChars:char []) (str:string) = - str.Trim(trimChars) - /// Remove all leading whitespace - [] - let trimStart (trimChars:char []) (str:string) = - str.TrimStart(trimChars) - /// Remove all trailing whitespace - [] - let trimEnd(trimChars:char []) (str:string) = - str.TrimEnd(trimChars) - - /// Match a regular expression - /// Return Some [grps] where m is the match string, - /// grps is the list of match groups (if any) - /// return None on no match - [] - let regexMatchGroups (regex:string) (str:string) = - let m = Text.RegularExpressions.Regex.Match(str, regex) - if m.Success then - Some [ for n in [1..m.Groups.Count] -> m.Groups[n].Value ] - else None - - /// Match a regular expression - /// Return Some m where m is the match string, - /// return None on no match - [] - let regexMatch (regex:string) (str:string) = - let m = Text.RegularExpressions.Regex(regex).Match(str) - if m.Success - then - Some m.Value // TODO workaround - //let mLst = [ for x in m.Groups -> x.Value ] - //Some (List.head mLst, List.tail mLst) - else None - - /// convert a System.XXX numeric parse function to idiomatic F# option. - /// e.g. String.TryParsewith System.Int32 will return Some n on successful Int32 parse or None. - [] - let tryParseWith (tryParseFunc: string -> bool*'T) = tryParseFunc >> function - | true, v -> Some v - | false, _ -> None - - -[] -[] -module List = - - [] - let pairWithPreviousOrSelf list = - match list with - | [] -> [] - | first :: rest -> (first,first) :: List.pairwise list - - [] - let toString (chars: char list) = chars |> Seq.ofList |> System.String.Concat - - /// Split list into list of lists each such that each element for which pred returns true starts a sublist. - /// Every sublist must contain at least one element. - /// Every sublist except possibly the first starts with an element el for which pred el is true - [] - let chunkAt1 pred lst = - let mutable i = 0 // should optimise this using sequences and yield! to group by subarray - [ for el in lst do - if pred el then i <- i + 1 - yield (i, el); - yield! []] - |> List.groupBy fst - |> List.sortBy fst - |> List.map (snd >> (List.map snd)) - - /// Split list into list of lists each such that each element for which pred returns true starts a sublist. - /// Every sublist must contain at least one element. - /// Every sublist except possibly the first starts with an element el for which pred el is true. - [] - let chunkAt pred list = - let rec loop chunk chunks list = - match list with - | [] -> List.rev ((List.rev chunk)::chunks) - | x::xs when pred x && List.isEmpty chunk -> loop [x] chunks xs - | x::xs when pred x -> loop [x] ((List.rev chunk)::chunks) xs - | x::xs -> loop (x::chunk) chunks xs - loop [] [] list - - - /// Extract Ok elements from result list, return list of Ok values - - - - - - - - [] - let okList lst = [ for x in lst do match x with | Ok y -> yield y | _ -> (); yield! []] - - /// Extract Error elements from result list, return list of errors - [] - let errorList lst = [ for x in lst do match x with | Error y -> yield y | _ -> (); yield! []] - - /// split Result list into pair of Ok and Error value lists repectively - [] - let splitResult resL = - List.fold (fun (rl,el) -> function | Error e -> rl, e :: el | Ok r -> r :: rl, el) ([],[]) resL - - -[] -[] -module Array = - - [] - let toString (chars: char array) = chars |> Seq.ofArray |> System.String.Concat - - /// Split array into array of arrays each such that each element for which pred returns true starts a subarray. - /// Every subarray must contain at least one element. - /// Every subarray except possibly the first starts with an element el for which pred el is true. - [] - let chunkAt pred arr = // should optimise this using sequences and yield! to group by subarray - let mutable i = 0 - [| for x in arr do - if pred x then i <- i + 1 - yield i, x |] - |> Array.groupBy fst - |> Array.map (snd >> (Array.map snd)) - - - -[] -[] -module Map = - /// Looks up key in table, returning defaultValue if - /// key is not in table - [] - let findWithDefault (key:'Key) (table:Map<'Key,'Value>) (defaultValue:'Value) = - match table.TryFind key with | Some v -> v |None -> defaultValue - - /// Return array of all values in table - [] - let values (table:Map<'Key,'Value>) = - table |> Map.toArray |> Array.map snd - - /// Return array of all keys in table - [] - let keys (table:Map<'Key,'Value>) = - table |> Map.toArray |> Array.map fst - - - - - +(* + This module contains some general purpose library functions +*) + +namespace EEExtensions +/// CHANGELIST +/// July 2018: add String.regexMatchGroups, correct documentation for regexMatch + +/// Miscellaneous extensions to core F# library functions +/// Additions to Char, String, Map + + +/// various functions that exist in normal F# but cannot work in fable +module FableReplacements = + let optionMap2 f v1 v2 = match v1, v2 with + | Some v1, Some v2 -> Some (f v1 v2) + | _ -> None + + let listChunkBySize chunkSize l = + let rec listChunkBySize' state chunksLeft itemsRemaining = + match chunksLeft, itemsRemaining with + | _, [] -> state + | 0, _ -> listChunkBySize' ([] :: state) chunkSize itemsRemaining + | _, nextItem::itemsTail -> listChunkBySize' ((nextItem :: List.head state) :: (List.tail state)) (chunksLeft - 1) itemsTail + + match l with + | [] -> [] + | _ -> listChunkBySize' [] 0 l |> List.map List.rev |> List.rev + + let hexToString (x : uint32) = + let rec loop str = + function + | 0u -> str + | num -> loop ((sprintf "%X" (num % 16u)) + str) (num / 16u) + match x with + | 0u -> "0" + | _ -> loop "" x + +// Following char method to convert to integer is partly based on code found on +// http://www.fssnip.net/25/title/Hex-encode-decode +[] +[] +module Char = + + [] + let inline IsLetterOrDigitOrUnderscore(ch: char): bool = + System.Char.IsLetterOrDigit ch || ch = '_' + + [] + let inline toInt(ch: char): int = + match ch with + | c when c >= '0' && c <= '9' -> int c - int '0' + | c when c >= 'a' && c <= 'f' -> (int c - int 'a') + 10 + | c when c >= 'A' && c <= 'F' -> (int c - int 'A') + 10 + | _ -> failwithf "What ? Error while converting character to digit" + +[] +[] +module String = + + open System + + [] + let inline ofChar( ch: char): string = [| ch |] |> Seq.ofArray |> System.String.Concat + + [] + let inline ofSeq (chars: char seq) : string = System.String.Concat chars + + [] + let inline toSeq (str: string) : char seq = str :> char seq + + [] + let inline ofList (chars: char list) = chars |> Seq.ofList |> System.String.Concat + + + [] + let inline ofArray (chars: char array) = chars |> Seq.ofArray |> System.String.Concat + + [] + let inline toList (str: string): char list = str |> List.ofSeq + + [] + let inline toArray (str: string): char array = str |> Array.ofSeq + + /// splits text into its array of non-whitepace strings separated by whitespace + [] + let splitOnWhitespace (text:string): string array = + text.Split( ([||]: char array) , System.StringSplitOptions.RemoveEmptyEntries) + + let [] DefaultComparison = StringComparison.Ordinal + let inline emptyIfNull str = + match str with + | null -> String.Empty + | _ -> str + /// Concatenate a sequence of strings + /// Using sep as separator + [] + let concat sep (strings : seq) = + String.Join(sep, strings) + + [] + let length (str:string) = + let str = emptyIfNull str + str.Length + + /// True if str contains value + [] + let contains (value:string) (str:string) = + str.Contains(value) + + [] + let compare (strB:string) (strA:string) = + String.Compare(strA, strB, DefaultComparison) + + /// True if str ends with value + [] + let endsWith (value:string) (str:string) = + str.EndsWith(value, DefaultComparison) + /// See String.Equals + [] + let equals (comparisonType:StringComparison) (value:string) (str:string) = + str.Equals(value, comparisonType) + + let inline checkIndex func (comparisonType:StringComparison) value = + let index = func(value, comparisonType) + if index = -1 then None + else Some index + + /// Replace all occurences of oldChar by newchar + [] + let replaceChar (oldChar:char) (newChar:char) (str:string) = + str.Replace(oldChar, newChar) + + /// Replace all occurences of oldValue by newValue + [] + let replace (oldValue:string) (newValue:string) (str:string) = + str.Replace(oldValue, newValue) + + /// Split str at all of separator array elements + /// Return array of strings + /// Adjacent separators generate empty strings + [] + let split (separator:char array) (str:string) = + str.Split(separator, StringSplitOptions.None) + + /// Split str at all of separator array elements + /// Return array of strings + /// Adjacent separators do not generate strings + [] + let splitRemoveEmptyEntries (separator:char array) (str:string) = + str.Split(separator, StringSplitOptions.RemoveEmptyEntries) + + /// Split str at all of separator string array elements + /// Return array of strings + /// Adjacent separators generate empty strings + [] + let splitString (separator:string array) (str:string) = + str.Split(separator, StringSplitOptions.None) + /// Split str at all of separator string array elements + /// Return array of strings + /// Adjacent separators do not generate strings + [] + let splitStringRemoveEmptyEntries (separator:string array) (str:string) = + str.Split(separator, StringSplitOptions.RemoveEmptyEntries) + + /// Return true if str starts with value + [] + let startsWith (value:string) (str:string) = + str.StartsWith(value, DefaultComparison) + + /// Return true if str starts with a letter + [] + let startsWithLetter (str:string) = + str <> "" && System.Char.IsLetter str[0] + + + /// Return substring of str at startIndex of length chars + /// Throw ArgumentOutOfRange exception if any part of + /// selected string lies outside str. + [] + let substringLength (startIndex:int) (length: int) (str:string) = + str.Substring(startIndex, length) + /// Return str from startIndex till end + /// Throw ArgumentOutOfRange exception if startWith + /// lies outside str + [] + let substring (startIndex:int) (str:string) = + str.Substring(startIndex) + + [] + let toLower(str:string) = + str.ToLowerInvariant() + + [] + let toUpper(str:string) = + str.ToUpperInvariant() + /// Remove all leading and training whitespace + [] + let trim(str:string) = + str.Trim() + /// Remove all leading and trailing chars in trimChars + [] + let trimChars (trimChars:char []) (str:string) = + str.Trim(trimChars) + /// Remove all leading whitespace + [] + let trimStart (trimChars:char []) (str:string) = + str.TrimStart(trimChars) + /// Remove all trailing whitespace + [] + let trimEnd(trimChars:char []) (str:string) = + str.TrimEnd(trimChars) + + /// Match a regular expression + /// Return Some [grps] where m is the match string, + /// grps is the list of match groups (if any) + /// return None on no match + [] + let regexMatchGroups (regex:string) (str:string) = + let m = Text.RegularExpressions.Regex.Match(str, regex) + if m.Success then + Some [ for n in [1..m.Groups.Count] -> m.Groups[n].Value ] + else None + + /// Match a regular expression + /// Return Some m where m is the match string, + /// return None on no match + [] + let regexMatch (regex:string) (str:string) = + let m = Text.RegularExpressions.Regex(regex).Match(str) + if m.Success + then + Some m.Value // TODO workaround + //let mLst = [ for x in m.Groups -> x.Value ] + //Some (List.head mLst, List.tail mLst) + else None + + /// convert a System.XXX numeric parse function to idiomatic F# option. + /// e.g. String.TryParsewith System.Int32 will return Some n on successful Int32 parse or None. + [] + let tryParseWith (tryParseFunc: string -> bool*'T) = tryParseFunc >> function + | true, v -> Some v + | false, _ -> None + + +[] +[] +module List = + + [] + let pairWithPreviousOrSelf list = + match list with + | [] -> [] + | first :: rest -> (first,first) :: List.pairwise list + + [] + let toString (chars: char list) = chars |> Seq.ofList |> System.String.Concat + + /// Split list into list of lists each such that each element for which pred returns true starts a sublist. + /// Every sublist must contain at least one element. + /// Every sublist except possibly the first starts with an element el for which pred el is true + [] + let chunkAt1 pred lst = + let mutable i = 0 // should optimise this using sequences and yield! to group by subarray + [ for el in lst do + if pred el then i <- i + 1 + yield (i, el); + yield! []] + |> List.groupBy fst + |> List.sortBy fst + |> List.map (snd >> (List.map snd)) + + /// Split list into list of lists each such that each element for which pred returns true starts a sublist. + /// Every sublist must contain at least one element. + /// Every sublist except possibly the first starts with an element el for which pred el is true. + [] + let chunkAt pred list = + let rec loop chunk chunks list = + match list with + | [] -> List.rev ((List.rev chunk)::chunks) + | x::xs when pred x && List.isEmpty chunk -> loop [x] chunks xs + | x::xs when pred x -> loop [x] ((List.rev chunk)::chunks) xs + | x::xs -> loop (x::chunk) chunks xs + loop [] [] list + + + /// Extract Ok elements from result list, return list of Ok values + + + + + + + + [] + let okList lst = [ for x in lst do match x with | Ok y -> yield y | _ -> (); yield! []] + + /// Extract Error elements from result list, return list of errors + [] + let errorList lst = [ for x in lst do match x with | Error y -> yield y | _ -> (); yield! []] + + /// split Result list into pair of Ok and Error value lists repectively + [] + let splitResult resL = + List.fold (fun (rl,el) -> function | Error e -> rl, e :: el | Ok r -> r :: rl, el) ([],[]) resL + + +[] +[] +module Array = + + [] + let toString (chars: char array) = chars |> Seq.ofArray |> System.String.Concat + + /// Split array into array of arrays each such that each element for which pred returns true starts a subarray. + /// Every subarray must contain at least one element. + /// Every subarray except possibly the first starts with an element el for which pred el is true. + [] + let chunkAt pred arr = // should optimise this using sequences and yield! to group by subarray + let mutable i = 0 + [| for x in arr do + if pred x then i <- i + 1 + yield i, x |] + |> Array.groupBy fst + |> Array.map (snd >> (Array.map snd)) + + + +[] +[] +module Map = + /// Looks up key in table, returning defaultValue if + /// key is not in table + [] + let findWithDefault (key:'Key) (table:Map<'Key,'Value>) (defaultValue:'Value) = + match table.TryFind key with | Some v -> v |None -> defaultValue + + /// Return array of all values in table + [] + let values (table:Map<'Key,'Value>) = + table |> Map.toArray |> Array.map snd + + /// Return array of all keys in table + [] + let keys (table:Map<'Key,'Value>) = + table |> Map.toArray |> Array.map fst + + /// Add a list of key-value tuple pairs to a table + [] + let addlist (list:('Key * 'Value) list) (table:Map<'Key,'Value>) = + list |> List.fold (fun acc (k,v) -> Map.add k v acc) table + + /// Return list of table keys + [] + let keysL (table:Map<'Key,'Value>) = + table |> Map.toList |> List.map fst + + /// Return list of table values + [] + let valuesL (table:Map<'Key,'Value>) = + table |> Map.toList |> List.map snd + + /// Return array of table keys + [] + let keysA (table:Map<'Key,'Value>) = + table |> Map.toArray |> Array.map fst + + /// Return array of table values + [] + let valuesA (table:Map<'Key,'Value>) = + table |> Map.toArray |> Array.map snd + + + + + + + + + + diff --git a/src/Renderer/DrawBlock/BlockHelpers.fs b/src/Renderer/DrawBlock/BlockHelpers.fs index 001b5df65..43af91781 100644 --- a/src/Renderer/DrawBlock/BlockHelpers.fs +++ b/src/Renderer/DrawBlock/BlockHelpers.fs @@ -6,12 +6,359 @@ open DrawModelType.BusWireT open Optics open Optics.Operators +module Constants = + let intervalTolerance = 0.0001 + + +// +-------------------------------+ // +// | | // +// | Temporary Types and Helpers | // +// | | // +// +-------------------------------+ // + +// TO PHASE OUT AND GO INTO COMMONTYPES +// I cannot put this in commontypes and import commontypes. +// This is because of the type name clash between ScaleAdjustment and Orientation +// Todo: Fix CommonTypes, import it, and remove this Rectangle type + +type Rectangle = { + TopLeft: XYPos + BottomRight: XYPos +} + + with + member this.Centre = (this.TopLeft + this.BottomRight) * 0.5 + member this.ToBoundingBox() = {|TopLeft=this.TopLeft; W=this.BottomRight.X - this.TopLeft.X; H=this.BottomRight.Y - this.TopLeft.Y|} + static member inline epsilon = 0.0001 + static member inline (=~)(left: Rectangle, right: Rectangle) = + left.TopLeft =~ right.TopLeft && left.BottomRight =~ right.BottomRight + + + +/// tdc21: Helper to convert a BoundingBox to a Rectangle +// We have to define this separately simply because we cannot import Common Types, as there is a type name clash between ScaleAdjustment and Orientation +// Commontypes already has this built-in as a BoundingBox member +// Todo: Fix CommonTypes and remove this function +let boundingBoxToRect (boundingBox: BoundingBox):Rectangle = + let bottomRight = boundingBox.TopLeft + { X = boundingBox.W; Y = boundingBox.H } + { TopLeft = boundingBox.TopLeft; BottomRight = bottomRight } + +/// tdc21: Helper to convert a Rectangle to a BoundingBox +// We have to define this separately simply because we cannot import Common Types, as there is a type name clash between ScaleAdjustment and Orientation +// Commontypes already has this built-in as a BoundingBox member +// Todo: Fix CommonTypes and remove this function +let rectToBoundingBox (rect: Rectangle) : BoundingBox = + let w = rect.BottomRight.X - rect.TopLeft.X + let h = rect.BottomRight.Y - rect.TopLeft.Y + { TopLeft = rect.TopLeft; W = w; H = h } + +/// tdc21 Helper to convert a 2D line segment (start position and end position) to a rectangle. +/// Will fail if segment travels in both directions +let segmentToRect (segStart: XYPos) (segEnd: XYPos) : Rectangle = + // segments must travel strictly straight in one direction, otherwise, raise an error + + // invalid case when segment travels in both directions + if abs (segStart.X - segEnd.X) > XYPos.epsilon && abs (segStart.Y - segEnd.Y) > XYPos.epsilon then + failwith "Segment must travel strictly in one direction" + + let topLeft, bottomRight = + match segStart.X <= segEnd.X && segStart.Y <= segEnd.Y with + | true -> segStart, segEnd + | false -> segEnd, segStart + + { TopLeft = topLeft; BottomRight = bottomRight } + + + +// +------------------------------+ // +// | | // +// | Intersection-Related Helpers | // +// | | // +// +------------------------------+ // + +/// DEPRECATED: Please use intersect1D instead. +/// Returns true if two 1D line segments intersect. Will account for point intersections (if ends are equal) +/// HLP23: Derek Lai (ddl20) +// Todo: Refactor all of codebase to use intersect1D, which is a drop-in replacement for overlap1D +let overlap1D ((a1, a2): float * float) ((b1, b2): float * float) : bool = + let a_min, a_max = min a1 a2, max a1 a2 + let b_min, b_max = min b1 b2, max b1 b2 + // a_max >= b_min && b_max >= a_min + // adjust for floating point errors? + a_max - b_min >= -XYPos.epsilon && b_max - a_min >= -XYPos.epsilon + + +/// tdc21: Returns true if two 1D line segments intersect. Will account for point intersections (if ends are equal) +let intersect1D ((a1, a2): float * float) ((b1, b2): float * float) : bool = + let a_min, a_max = min a1 a2, max a1 a2 + let b_min, b_max = min b1 b2, max b1 b2 + a_max - b_min >= -XYPos.epsilon && b_max - a_min >= -XYPos.epsilon + + +/// tdc21: Returns the overlapping segment line of two 1D line segments if they intersect, else None. +/// Will account for point intersections (if ends are equal) +/// If intersection is a point, the overlapping segment returned will have the same start and end points +let intersect1DInfo ((a1, a2): float * float) ((b1, b2): float * float) : (float * float) option = + let a_min, a_max = min a1 a2, max a1 a2 + let b_min, b_max = min b1 b2, max b1 b2 + match a_max >= b_min && b_max >= a_min with + | true -> Some (max a_min b_min, min a_max b_max) + | false -> None + + +/// DEPRECATED: Please use intersect2D instead with the rectangle type. +/// Returns true if two Boxes intersect, where each box is passed in as top right and bottom left XYPos tuples. Will account for point intersections (if ends are equal) +/// HLP23: Derek Lai (ddl20) +// Todo: Refactor all of codebase to use intersect2D +let overlap2D ((a1, a2): XYPos * XYPos) ((b1, b2): XYPos * XYPos) : bool = + (overlap1D (a1.X, a2.X) (b1.X, b2.X)) && (overlap1D (a1.Y, a2.Y) (b1.Y, b2.Y)) + +/// tdc21: Returns the area of the overlap between two Rectangles if they intersect. Will account for point intersections (if ends are equal) +/// Refactored version of overlap2D to use Rectangle type. Replaces overlap2D +let intersect2D (rect1: Rectangle) (rect2 : Rectangle) : bool = + ( intersect1D (rect1.TopLeft.X, rect1.BottomRight.X) (rect2.TopLeft.X, rect2.BottomRight.X) + && intersect1D (rect1.TopLeft.Y, rect1.BottomRight.Y) (rect2.TopLeft.Y, rect2.BottomRight.Y)) + + +/// tdc21: Returns the area of the overlap between two rectangles if they intersect, else None +/// Accounts for point intersections (if endpoints/corners are equal). +/// If intersection is a point, the rectangle returned will have TopLeft as the point coordinate, BottomRight as the same point +/// If intersection is a line, the rectangle returned will have the TopLeft and BottomRight sharing either the same X or Y coordinate (zero width or height) +let intersect2DInfo (rect1) (rect2): Rectangle Option = + // these are 2 x coordinates of the overlap + let xOverlapVertices = intersect1DInfo (rect1.TopLeft.X, rect1.BottomRight.X) (rect2.TopLeft.X, rect2.BottomRight.X) + // these are 2 y coordinates of the overlap + let yOverlapVertices = intersect1DInfo (rect1.TopLeft.Y, rect1.BottomRight.Y) (rect2.TopLeft.Y, rect2.BottomRight.Y) + match xOverlapVertices, yOverlapVertices with + | Some (x1, x2), Some (y1, y2) -> + let TopLeft = { X = (min x1 x2); Y = (min y1 y2) } + let BottomRight = { X = (max x1 x2); Y = (max y1 y2) } + Some { TopLeft = TopLeft; BottomRight = BottomRight } + | _, _ -> None + + +/// DEPRECATED. Please use intersect2DBox instead. It is a drop-in replacement so functionality/arguments are identical. +/// Returns true if two Boxes intersect, where each box is passed in as a BoundingBox +/// HLP23: Derek Lai (ddl20) +let overlap2DBox (bb1: BoundingBox) (bb2: BoundingBox) : bool = + let bb1Coords = + { X = bb1.TopLeft.X; Y = bb1.TopLeft.Y }, + { X = bb1.TopLeft.X + bb1.W + Y = bb1.TopLeft.Y + bb1.H } + + let bb2Coords = + { X = bb2.TopLeft.X; Y = bb2.TopLeft.Y }, + { X = bb2.TopLeft.X + bb2.W + Y = bb2.TopLeft.Y + bb2.H } + + overlap2D bb1Coords bb2Coords + + + +/// tdc21: Returns true if two Boxes intersect, where each box is passed in as a BoundingBox. +/// Accounts for point intersections (if endpoints/corners are equal) +/// Drop-in replacement for overlap2DBox. +// Todo: fix commontypes and import it, so we we can use the built in functions currently commented out +let intersect2DBox (bb1: BoundingBox) (bb2: BoundingBox) : bool = + // let rect1: Rectangle = bb1.ToRect + // let rect2: Rectangle = bb2.ToRect + + let rect1, rect2 = boundingBoxToRect bb1, boundingBoxToRect bb2 + intersect2D rect1 rect2 + + + +/// tdc21: Returns a bounding box of intersection area between two bounding boxes if they intersect, else None +/// Accounts for point intersections (if endpoints/corners are equal). +/// If intersection is a point, the boundingBox returned will have TopLeft as the point coordinate, H=0, W=0 +/// If intersection is a line, the boundingBox returned will have the either H=0 or W=0 but not both +/// If intersection is in 2D, the boundingBox returned will have both H and W > 0 +// Todo: fix commontypes and import it, so we we can use the built in functions currently commented out +let intersect2DBoxInfo (bb1 : BoundingBox) (bb2 : BoundingBox) : BoundingBox option = + // let rect1: Rectangle = bb1.ToRect + // let rect2: Rectangle = bb2.ToRect + + let rect1, rect2 = boundingBoxToRect bb1, boundingBoxToRect bb2 + + match (intersect2DInfo rect1 rect2) with + | Some rect -> Some (rectToBoundingBox rect) + | None -> None + + +/// tdc21: Returns true if two 1D line segments intersect in 2D space. Will account for point intersections (if ends are equal) +let segmentIntersectsSegment (a1: XYPos, a2: XYPos) (b1: XYPos, b2: XYPos) : bool = + intersect1D (a1.X, a2.X) (b1.X, b2.X) && intersect1D (a1.Y, a2.Y) (b1.Y, b2.Y) + +/// tdc21: Returns the rectangle of the overlap between two 1D line segments if they intersect, else None. +/// The rectangle can either be 1D (TopLeft = BottomRight) or 2D +/// Will account for point intersections (if ends are equal) +let segmentIntersectsSegmentInfo (a1: XYPos, a2: XYPos) (b1: XYPos, b2: XYPos) : Rectangle option = + let xOverlapVertices = intersect1DInfo (a1.X, a2.X) (b1.X, b2.X) + let yOverlapVertices = intersect1DInfo (a1.Y, a2.Y) (b1.Y, b2.Y) + match xOverlapVertices, yOverlapVertices with + | Some (x1, x2), Some (y1, y2) -> + let TopLeft = { X = (min x1 x2); Y = (min y1 y2) } + let BottomRight = { X = (max x1 x2); Y = (max y1 y2) } + Some { TopLeft = TopLeft; BottomRight = BottomRight } + | _, _ -> None + + +/// tdc21: Returns true if a segment intersects a bounding box using the segment's start and end XYPos +/// Will account for point intersections (if ends are equal). +let segmentIntersectsBoundingBox (box: BoundingBox) segStart segEnd = + let inline lThanEqualPos (p1: XYPos) (p2: XYPos) : bool = + p1.X <= p2.X && p1.Y <= p2.Y + + let topLeft = + if lThanEqualPos segStart segEnd then + segStart + else + segEnd + let segBBox = + match abs ((segStart - segEnd).X), abs ((segStart - segEnd).Y) with + | x, y when abs x <= XYPos.epsilon -> Some { TopLeft = topLeft; W = 0.0; H = y } + | x, y when abs y <= XYPos.epsilon -> Some { TopLeft = topLeft; W = x; H = 0.0 } + | _, _ -> None // we don't do this for zero length segments + + match segBBox with + | Some segBBox -> overlap2DBox box segBBox + | _ -> false + +/// tdc21: Returns the bounding box of the intersection between a segment and a bounding box if they intersect, else None +/// Accounts for point intersections. +/// If intersection is a point, the boundingBox returned will have TopLeft as the point coordinate, H=0, W=0 +/// If intersection is a line, the boundingBox returned will have the either H=0 or W=0 but not both +/// There should be no 2D intersections +let segmentIntersectsBoundingBoxInfo (box: BoundingBox) segStart segEnd = + let inline lThanEqualPos (p1: XYPos) (p2: XYPos) : bool = + p1.X <= p2.X && p1.Y <= p2.Y + + let topLeft = + if lThanEqualPos segStart segEnd then + segStart + else + segEnd + let segBBox = + match abs ((segStart - segEnd).X), abs ((segStart - segEnd).Y) with + | x, y when abs x <= XYPos.epsilon -> Some { TopLeft = topLeft; W = 0.0; H = y } + | x, y when abs y <= XYPos.epsilon -> Some { TopLeft = topLeft; W = x; H = 0.0 } + | _, _ -> None // we don't do this for zero length segments + + match segBBox with + | Some segBBox -> intersect2DBoxInfo box segBBox + | _ -> None + + + + + +/// Converts a segment list into a list of vertices to store inside Connection +/// It is assumed the segments in segList are updated to match the wire segments. +/// This is guaranteed if they all come from updated wire segments. +/// To update, call updateWireSegmentJumpsAndSeparations from BusWireSeparate.fs before +let segmentsToIssieVertices (segList:Segment list) (wire:Wire) = + ((wire.StartPos, wire.InitialOrientation, false),segList) + ||> List.scan(fun (currPos, currOrientation, _) seg -> + let (nextPos, nextOrientation) = + match currOrientation with + | Horizontal -> { currPos with X = currPos.X + seg.Length}, Vertical + | Vertical -> { currPos with Y = currPos.Y + seg.Length}, Horizontal + let manual = (seg.Mode = Manual) + (nextPos,nextOrientation,manual)) + |> List.map ( fun (pos,_,manual) -> pos.X,pos.Y,manual) + + + + +//-------------------------- types and functions related to BusWireRouting -------------// +//-------------------------segmentIntersectsBoundingBox---------------------------------// + +// Type used to simplify BoundingBox intersection calculations +// type Rectangle = { +// TopLeft: XYPos +// BottomRight: XYPos +// } + +// /// Returns the X-value of an XYPos +// let inline toX (pos: XYPos) = pos.X + +// /// Returns the Y-value of an XYPos +// let inline toY (pos: XYPos) = pos.Y + +// /// Returns the X and Y fields of an XYPos as a pair of floats +// let inline getXY (pos: XYPos) = pos.X, pos.Y + +/// Returns pos with the X and Y fields scaled by factor (I didn't like the order of parameters for the * operator in XYPos) +let inline scalePos (factor: float) (pos: XYPos) : XYPos = + { X = factor * pos.X; Y = factor * pos.Y} + +/// Returns true if p1 is less than or equal to p2 (has both smaller X and Y values +let inline lThanEqualPos (p1: XYPos) (p2: XYPos) : bool = + p1.X <= p2.X && p1.Y <= p2.Y + +/// Returns the dot product of 2 XYPos +let inline dotProduct (p1: XYPos) (p2: XYPos) : float = + p1.X * p2.X + p1.Y * p2.Y + +/// Returns the squared distance between 2 points using Pythagoras +let inline squaredDistance (p1: XYPos) (p2: XYPos) = + let diff = p1 - p2 + dotProduct diff diff + +/// Checks if 2 rectangles intersect +let rectanglesIntersect (rect1: Rectangle) (rect2: Rectangle) = + /// Returns the X-value of an XYPos + let inline toX (pos: XYPos) = pos.X + + /// Returns the Y-value of an XYPos + let inline toY (pos: XYPos) = pos.Y + + /// Checks if there is an intersection in the X or Y dimension + let intersect1D (xOrY: XYPos -> float): bool = + let qHi = min (xOrY rect1.BottomRight) (xOrY rect2.BottomRight) + let qLo = max (xOrY rect1.TopLeft) (xOrY rect2.TopLeft) + qLo <= qHi + + (intersect1D toX) && (intersect1D toY) + +let findPerpendicularDistance (segStart:XYPos) (segEnd:XYPos) (point:XYPos) = + match abs (segStart.X - segEnd.X) > abs (segStart.Y - segEnd.Y) with + | true -> abs (segStart.Y - point.Y) + | false -> abs (segStart.X - point.X) + +/// Checks if a segment intersects a bounding box using the segment's start and end XYPos +/// return how close the segment runs to the box centre, if it intersects +// tdc21: This was orignally called segmentIntersectsBoundingBox, but now renamed as segmentIntersectsBoundingBoxDistance +// to reflect it returning the closest (perpend.) distance to the box centre if it intersects the box, rather than returning a boolean (true = intersects, false = does not intersect) +// segmentIntersectsBoundingBox is now the name function that returns true if a segment intersects a bounding box +let segmentIntersectsBoundingBoxDistance (box: BoundingBox) segStart segEnd = + let toRect p1 p2 = + let topLeft, bottomRight = + if lThanEqualPos p1 p2 then + p1, p2 + else + p2, p1 + + { TopLeft = topLeft + BottomRight = bottomRight } + + let bbBottomRight = + { X = box.TopLeft.X + box.W + Y = box.TopLeft.Y + box.H } + + let bbRect = toRect box.TopLeft bbBottomRight + let segRect = toRect segStart segEnd + + if rectanglesIntersect bbRect segRect then + Some <| findPerpendicularDistance segStart segEnd ((box.TopLeft + bbBottomRight) * 0.5) + else + None + //-----------------------------------------------------------------------------------------------// //---------------------------HELPERS FOR SMART DRAW BLOCK ADDITIONS------------------------------// //-----------------------------------------------------------------------------------------------// -module Constants = - let intervalTolerance = 0.0001 + open Constants /// Update BusWire model with given symbols. Can also be used to add new symbols. @@ -45,7 +392,7 @@ let updateModelWires (model: BusWireT.Model) (wiresToAdd: Wire list) : BusWireT. let moveSymbol (offset:XYPos) (sym:Symbol) :Symbol = let newPos = sym.Pos + offset let comp' = {sym.Component with X = newPos.X; Y = newPos.Y} - {sym with + {sym with Component = comp' Pos = newPos LabelBoundingBox = {sym.LabelBoundingBox with TopLeft = sym.LabelBoundingBox.TopLeft + offset} @@ -53,7 +400,7 @@ let moveSymbol (offset:XYPos) (sym:Symbol) :Symbol = let moveSymbols (offset: XYPos) (model:SymbolT.Model) = {model with - Symbols = + Symbols = model.Symbols |> Map.map (fun _ symbol -> moveSymbol offset symbol) } @@ -61,45 +408,7 @@ let moveSymbols (offset: XYPos) (model:SymbolT.Model) = let inline inputPortStr (InputPortId s) = s let inline outputPortStr (OutputPortId s) = s -/// Returns true if two 1D line segments intersect -/// HLP23: Derek Lai (ddl20) -let overlap1D ((a1, a2): float * float) ((b1, b2): float * float) : bool = - let a_min, a_max = min a1 a2, max a1 a2 - let b_min, b_max = min b1 b2, max b1 b2 - a_max >= b_min && b_max >= a_min - - -/// Converts a segment list into a list of vertices to store inside Connection -let segmentsToIssieVertices (segList:Segment list) (wire:Wire) = - ((wire.StartPos, wire.InitialOrientation, false),segList) - ||> List.scan(fun (currPos, currOrientation, _) seg -> - let (nextPos, nextOrientation) = - match currOrientation with - | Horizontal -> { currPos with X = currPos.X + seg.Length}, Vertical - | Vertical -> { currPos with Y = currPos.Y + seg.Length}, Horizontal - let manual = (seg.Mode = Manual) - (nextPos,nextOrientation,manual)) - |> List.map ( fun (pos,_,manual) -> pos.X,pos.Y,manual) - -/// Returns true if two Boxes intersect, where each box is passed in as top right and bottom left XYPos tuples -/// HLP23: Derek Lai (ddl20) -let overlap2D ((a1, a2): XYPos * XYPos) ((b1, b2): XYPos * XYPos) : bool = - (overlap1D (a1.X, a2.X) (b1.X, b2.X)) && (overlap1D (a1.Y, a2.Y) (b1.Y, b2.Y)) - -/// Returns true if two Boxes intersect, where each box is passed in as a BoundingBox -/// HLP23: Derek Lai (ddl20) -let overlap2DBox (bb1: BoundingBox) (bb2: BoundingBox) : bool = - let bb1Coords = - { X = bb1.TopLeft.X; Y = bb1.TopLeft.Y }, - { X = bb1.TopLeft.X + bb1.W - Y = bb1.TopLeft.Y + bb1.H } - - let bb2Coords = - { X = bb2.TopLeft.X; Y = bb2.TopLeft.Y }, - { X = bb2.TopLeft.X + bb2.W - Y = bb2.TopLeft.Y + bb2.H } - overlap2D bb1Coords bb2Coords /// Returns an XYPos shifted by length in an X or Y direction defined by orientation. @@ -114,9 +423,9 @@ let inline switchOrientation orientation = | Horizontal -> Vertical | Vertical -> Horizontal -/// Applies a function which requires the segment start and end positions to the segments in a wire, +/// Applies a function which requires the segment start and end positions to the segments in a wire, /// threading an accumulator argument through the computation. Essentially a List.fold applied to the list of segments of a wire, but with access to each segment's absolute positions. -/// This is used in cases where absolute segment positions are required. +/// This is used in cases where absolute segment positions are required. /// These positions are computed on the fly and passed to the folder function. /// The function to update the state given the segment start and end positions, current state and segment itself. /// The initial state. @@ -126,16 +435,16 @@ let inline foldOverSegs folder state wire = let initPos = wire.StartPos let initOrientation = wire.InitialOrientation ((state, initPos, initOrientation), wire.Segments) - ||> List.fold (fun (currState, currPos, currOrientation) seg -> + ||> List.fold (fun (currState, currPos, currOrientation) seg -> let nextPos = addLengthToPos currPos currOrientation seg.Length let nextOrientation = switchOrientation currOrientation let nextState = folder currPos nextPos currState seg (nextState, nextPos, nextOrientation)) |> (fun (state, _, _) -> state) -/// Applies a function which requires the segment start and end positions to the non-zero-length segments in a wire, +/// Applies a function which requires the segment start and end positions to the non-zero-length segments in a wire, /// threading an accumulator argument through the computation. Essentially a List.fold applied to the list of segments of a wire, but with access to each segment's absolute positions. -/// This is used in cases where absolute segment positions are required. +/// This is used in cases where absolute segment positions are required. /// These positions are computed on the fly and passed to the folder function. /// The function to update the state given the segment start and end positions, current state and segment itself. /// The initial state. @@ -145,9 +454,9 @@ let inline foldOverNonZeroSegs folder state wire = let initPos = wire.StartPos let initOrientation = wire.InitialOrientation ((state, initPos, initOrientation), wire.Segments) - ||> List.fold (fun (currState, currPos, currOrientation) seg -> + ||> List.fold (fun (currState, currPos, currOrientation) seg -> let nextOrientation = switchOrientation currOrientation - if seg.IsZero then + if seg.IsZero then (currState, currPos, nextOrientation) else let nextPos = addLengthToPos currPos currOrientation seg.Length @@ -161,7 +470,7 @@ let getAbsSegments (wire: Wire) : ASegment list = let convertToAbs ((start,dir): XYPos*Orientation) (seg: Segment) = {Start=start; End = addLengthToPos start dir seg.Length; Segment = seg} (((wire.StartPos,wire.InitialOrientation),[]), wire.Segments) - ||> List.fold (fun (posDir, aSegL) seg -> + ||> List.fold (fun (posDir, aSegL) seg -> let nextASeg = convertToAbs posDir seg let posDir' = nextASeg.End, switchOrientation (snd posDir) posDir', (nextASeg :: aSegL)) @@ -175,13 +484,13 @@ let getNonZeroAbsSegments (wire: Wire) : ASegment list = let convertToAbs ((start,dir): XYPos*Orientation) (seg: Segment) = {Start=start; End = addLengthToPos start dir seg.Length; Segment = seg} (((wire.StartPos,wire.InitialOrientation),[]), wire.Segments) - ||> List.fold (fun (posDir, aSegL) seg -> + ||> List.fold (fun (posDir, aSegL) seg -> let nextASeg = convertToAbs posDir seg let posDir' = nextASeg.End, switchOrientation (snd posDir) if not <| seg.IsZero then posDir', (nextASeg :: aSegL) else - posDir', aSegL) + posDir', aSegL) |> snd |> List.rev @@ -192,18 +501,18 @@ let getFilteredAbsSegments includeSegment (wire: Wire) : ASegment list = let convertToAbs ((start,dir): XYPos*Orientation) (seg: Segment) = {Start=start; End = addLengthToPos start dir seg.Length; Segment = seg} (((wire.StartPos,wire.InitialOrientation),[]), wire.Segments) - ||> List.fold (fun ((pos,ori), aSegL) seg -> + ||> List.fold (fun ((pos,ori), aSegL) seg -> let nextASeg = convertToAbs (pos,ori) seg let posDir' = nextASeg.End, switchOrientation ori - match includeSegment ori seg with + match includeSegment ori seg with | true -> posDir', (nextASeg :: aSegL) - | false -> posDir', aSegL) + | false -> posDir', aSegL) |> snd |> List.rev -type Wire with +type Wire with member inline this.EndOrientation = - match this.Segments.Length % 2, this.InitialOrientation with + match this.Segments.Length % 2, this.InitialOrientation with | 1, _ -> this.InitialOrientation | _, Vertical -> Horizontal | _, Horizontal -> Vertical @@ -260,15 +569,15 @@ let partitionWiresIntoNets (model:Model) = //------------------------------------------------------------------------------// /// Returns true if x lies in the open interval (a,b). Endpoints are avoided by a tolerance parameter -let inline inMiddleOf a x b = +let inline inMiddleOf a x b = let e = intervalTolerance a + e < x && x < b - e /// Returns true if a lies in the closed interval (a,b). Endpoints are included by a tolerance parameter -let inline inMiddleOrEndOf a x b = +let inline inMiddleOrEndOf a x b = let e = intervalTolerance a - e < x && x < b + e - + let inline getSourcePort (model:Model) (wire:Wire) = let portId = outputPortStr wire.OutputPort let port = model.Symbol.Ports[portId] @@ -332,21 +641,21 @@ let inline getCompId (model: SymbolT.Model) (portId: string) = symbol.Id /// Returns the string of a PortId -let inline getPortIdStr (portId: PortId) = +let inline getPortIdStr (portId: PortId) = match portId with | InputId (InputPortId id) -> id | OutputId (OutputPortId id) -> id -let inline getInputPortIdStr (portId: InputPortId) = +let inline getInputPortIdStr (portId: InputPortId) = match portId with | InputPortId s -> s -let inline getOutputPortIdStr (portId: OutputPortId) = +let inline getOutputPortIdStr (portId: OutputPortId) = match portId with | OutputPortId s -> s /// HLP23: AUTHOR dgs119 -let inline getPortOrientationFrmPortIdStr (model: SymbolT.Model) (portIdStr: string) : Edge = +let inline getPortOrientationFrmPortIdStr (model: SymbolT.Model) (portIdStr: string) : Edge = let port = model.Ports[portIdStr] let sId = ComponentId port.HostId model.Symbols[sId].PortMaps.Orientation[portIdStr] @@ -389,7 +698,7 @@ let getWireLength (wire: Wire) : float = /// Gets total length of a set of wires. /// HLP23: AUTHOR dgs119 -let totalLengthOfWires (conns: Map) = +let totalLengthOfWires (conns: Map) = conns |> Map.map(fun _ wire -> getWireLength wire) |> Map.toList @@ -465,7 +774,7 @@ let groupWiresByNet (conns: Map) = |> List.groupBy (fun (_, wire) -> wire.OutputPort) |> List.map (snd >> List.map snd) -/// Scales a symbol so it has the provided height and width. +/// Scales a symbol so it has the provided height and width. Works ONLY for custom components. /// HLP23: AUTHOR BRYAN TAN let setCustomCompHW (h: float) (w: float) (sym: Symbol) = let hScale = w / sym.Component.W @@ -476,7 +785,8 @@ let setCustomCompHW (h: float) (w: float) (sym: Symbol) = VScale = Some vScale } /// For a wire and a symbol, return the edge of the symbol that the wire is connected to. -/// /// HLP23: AUTHOR BRYAN TAN +/// If the wire does not connect to the symbol, defaults to returning Top. +/// HLP23: AUTHOR BRYAN TAN let wireSymEdge wModel wire sym = let sPort, tPort = getSourcePort wModel wire, getTargetPort wModel wire let sEdge = Map.tryFind sPort.Id sym.PortMaps.Orientation @@ -488,77 +798,3 @@ let wireSymEdge wModel wire sym = | _ -> Top // Shouldn't happen. -//-------------------------- types and functiond related to BusWireRouting -------------// -//-------------------------segmentIntersectsBoundingBox---------------------------------// - -/// Type used to simplify BoundingBox intersection calculations -type Rectangle = { - TopLeft: XYPos - BottomRight: XYPos -} - -/// Returns the X-value of an XYPos -let inline toX (pos: XYPos) = pos.X - -/// Returns the Y-value of an XYPos -let inline toY (pos: XYPos) = pos.Y - -/// Returns the X and Y fields of an XYPos as a pair of floats -let inline getXY (pos: XYPos) = pos.X, pos.Y - -/// Returns pos with the X and Y fields scaled by factor (I didn't like the order of parameters for the * operator in XYPos) -let inline scalePos (factor: float) (pos: XYPos) : XYPos = - { X = factor * pos.X; Y = factor * pos.Y} - -/// Returns true if p1 is less than or equal to p2 (has both smaller X and Y values -let inline lThanEqualPos (p1: XYPos) (p2: XYPos) : bool = - p1.X <= p2.X && p1.Y <= p2.Y - -/// Returns the dot product of 2 XYPos -let inline dotProduct (p1: XYPos) (p2: XYPos) : float = - p1.X * p2.X + p1.Y * p2.Y - -/// Returns the squared distance between 2 points using Pythagoras -let inline squaredDistance (p1: XYPos) (p2: XYPos) = - let diff = p1 - p2 - dotProduct diff diff - -/// Checks if 2 rectangles intersect -let rectanglesIntersect (rect1: Rectangle) (rect2: Rectangle) = - /// Checks if there is an intersection in the X or Y dimension - let intersect1D (xOrY: XYPos -> float): bool = - let qHi = min (xOrY rect1.BottomRight) (xOrY rect2.BottomRight) - let qLo = max (xOrY rect1.TopLeft) (xOrY rect2.TopLeft) - qLo <= qHi - - (intersect1D toX) && (intersect1D toY) - -let findPerpendicularDistance (segStart:XYPos) (segEnd:XYPos) (point:XYPos) = - match abs (segStart.X - segEnd.X) > abs (segStart.Y - segEnd.Y) with - | true -> abs (segStart.Y - point.Y) - | false -> abs (segStart.X - point.X) - -/// Checks if a segment intersects a bounding box using the segment's start and end XYPos -/// return how close teh segment runs to the box centre, if it intersects -let segmentIntersectsBoundingBox (box: BoundingBox) segStart segEnd = - let toRect p1 p2 = - let topLeft, bottomRight = - if lThanEqualPos p1 p2 then - p1, p2 - else - p2, p1 - - { TopLeft = topLeft - BottomRight = bottomRight } - - let bbBottomRight = - { X = box.TopLeft.X + box.W - Y = box.TopLeft.Y + box.H } - - let bbRect = toRect box.TopLeft bbBottomRight - let segRect = toRect segStart segEnd - - if rectanglesIntersect bbRect segRect then - Some <| findPerpendicularDistance segStart segEnd ((box.TopLeft + bbBottomRight) * 0.5) - else - None diff --git a/src/Renderer/DrawBlock/BusWireRoute.fs b/src/Renderer/DrawBlock/BusWireRoute.fs index 4c6462923..6c8d5a615 100644 --- a/src/Renderer/DrawBlock/BusWireRoute.fs +++ b/src/Renderer/DrawBlock/BusWireRoute.fs @@ -14,29 +14,29 @@ open Operators -(* -NOTE: For ease of understanding, algorithm, variable names and documentation of code below are all explained +(* +NOTE: For ease of understanding, algorithm, variable names and documentation of code below are all explained in the simple case of no rotated symbols (ie wire.InitialOrientation = Horizontal). However, the code implemented supports the rotated case as well. Implemented the following Smart Routing Algorithm: - 1) Check if initial autorouted wire has any intersections with symbols. + 1) Check if initial autorouted wire has any intersections with symbols. If yes, calculate the bounding boxes of all the intersected symbols. 2) Attempt to shift the vertical seg of the 7 seg wire to wireSeparationFromSymbol amount left of the left most - bound of the intersected symbols. + bound of the intersected symbols. If there are still intersections, try shifting to the right most bound + wireSeparationFromSymbol. - 3) If there are still intersections, recursively try to shift the horizontal seg of the 7 seg - or 9 seg wire to either the top or bottom most bound of the intersected symbols. - If both shifted wires still result in an intersection, compute the vertical distances between - the start/end pos of the wire and the top/bottom bound of the intersected symbols. - Using the 4 vertical distances computed, decide whether to try shifting the wire up or down + 3) If there are still intersections, recursively try to shift the horizontal seg of the 7 seg + or 9 seg wire to either the top or bottom most bound of the intersected symbols. + If both shifted wires still result in an intersection, compute the vertical distances between + the start/end pos of the wire and the top/bottom bound of the intersected symbols. + Using the 4 vertical distances computed, decide whether to try shifting the wire up or down depending on which results in a wire with shorter vertical distance. - - A max recursion depth is defined for step 3 so that Issie will not break when there are physically - no possible routes that will not intersect any symbol (eg when dragging a symbol around such that - the dragged symbol is within another symbol) or when there are special corner cases that have not + + A max recursion depth is defined for step 3 so that Issie will not break when there are physically + no possible routes that will not intersect any symbol (eg when dragging a symbol around such that + the dragged symbol is within another symbol) or when there are special corner cases that have not been implemented yet (eg symbol A is in top left quadrant with input port facing up, connected to symbol B in bottom right quadrant with output port facing down, with other symbols in between the 2 symbols). @@ -81,7 +81,7 @@ let findWireSymbolIntersections (model: Model) (wire: Wire) : BoundingBox list = let inputIsSelect = let inputSymbol = model.Symbol.Symbols.[ComponentId inputCompId] let inputCompInPorts = inputSymbol.Component.InputPorts - + componentIsMux inputSymbol.Component && (inputCompInPorts.[List.length inputCompInPorts - 1].Id = string wire.InputPort) let inputCompRotation = @@ -112,7 +112,7 @@ let findWireSymbolIntersections (model: Model) (wire: Wire) : BoundingBox list = match compType, lastSeg with | Mux2, true | Mux4, true | Mux8, true | Demux2, true | Demux4, true | Demux8, true -> false | _, _ -> - match segmentIntersectsBoundingBox boundingBox startPos endPos with // do not consider the symbols that the wire is connected to + match segmentIntersectsBoundingBoxDistance boundingBox startPos endPos with // do not consider the symbols that the wire is connected to | Some _ -> true // segment intersects bounding box | None -> false // no intersection ) @@ -488,16 +488,16 @@ let snapToNet (model: Model) (wireToRoute: Wire) : Wire = /// top-level function which replaces autoupdate and implements a smarter version of same /// it is called every time a new wire is created, so is easily tested. let smartAutoroute (model: Model) (wire: Wire) : Wire = - + let initialWire = (autoroute model wire) - + // Snapping to Net only if model.SnapToNet toggled to be true let snappedToNetWire = match model.SnapToNet with | _ -> initialWire // do not snap //| true -> snapToNet model initialWire - let intersectedBoxes = findWireSymbolIntersections model snappedToNetWire + let intersectedBoxes = findWireSymbolIntersections model snappedToNetWire match intersectedBoxes.Length with | 0 -> snappedToNetWire @@ -507,7 +507,7 @@ let smartAutoroute (model: Model) (wire: Wire) : Wire = tryShiftHorizontalSeg maxCallsToShiftHorizontalSeg model intersectedBoxes snappedToNetWire ) |> Option.defaultValue snappedToNetWire - + //-----------------------------------------------------------------------------------------------------------// @@ -516,23 +516,23 @@ let smartAutoroute (model: Model) (wire: Wire) : Wire = /// Returns a single re-routed wire from the given model. /// First attempts partial autorouting, and defaults to full autorouting if this is not possible. -/// Reverse indicates if the wire should be processed in reverse, +/// Reverse indicates if the wire should be processed in reverse, /// used when an input port (end of wire) is moved. let updateWire (model : Model) (wire : Wire) (reverse : bool) = - let newPort = + let newPort = match reverse with | true -> Symbol.getInputPortLocation None model.Symbol wire.InputPort | false -> Symbol.getOutputPortLocation None model.Symbol wire.OutputPort if reverse then partialAutoroute model (reverseWire wire) newPort true |> Option.map reverseWire - else + else partialAutoroute model wire newPort false |> Option.defaultWith (fun () -> smartAutoroute model wire) /// Re-routes the wires in the model based on a list of components that have been altered. -/// If the wire input and output ports are both in the list of moved components, +/// If the wire input and output ports are both in the list of moved components, /// it does not re-route wire but instead translates it. /// Keeps manual wires manual (up to a point). /// Otherwise it will auto-route wires connected to components that have moved @@ -543,7 +543,7 @@ let updateWires (model : Model) (compIdList : ComponentId list) (diff : XYPos) = let newWires = model.Wires |> Map.toList - |> List.map (fun (cId, wire) -> + |> List.map (fun (cId, wire) -> if List.contains cId wires.Both //Translate wires that are connected to moving components on both sides then (cId, moveWire wire diff) elif List.contains cId wires.Inputs //Only route wires connected to ports that moved for efficiency diff --git a/src/Renderer/DrawBlock/BusWireUpdate.fs b/src/Renderer/DrawBlock/BusWireUpdate.fs index 174291ffe..67c9abd32 100644 --- a/src/Renderer/DrawBlock/BusWireUpdate.fs +++ b/src/Renderer/DrawBlock/BusWireUpdate.fs @@ -19,13 +19,13 @@ open BlockHelpers //---------------------------------------------------------------------------------// /// Initialises an empty BusWire Model -let init () = +let init () = let symbols,_ = SymbolView.init() - { + { Wires = Map.empty; - Symbol = symbols; - CopiedWires = Map.empty; - SelectedSegment = []; + Symbol = symbols; + CopiedWires = Map.empty; + SelectedSegment = []; LastMousePos = {X = 0.0; Y = 0.0}; ErrorWires = [] Notifications = None @@ -36,21 +36,21 @@ let init () = let dragSegment wire index (mMsg: MouseT) model = match List.tryItem index wire.Segments with - | None -> + | None -> printfn "Bad segment in Dragsegment... ignoring drag" model | Some seg when index < 1 || index > wire.Segments.Length-2 -> printfn "Bad index - can't move that segment" model - | Some seg -> + | Some seg -> let (startPos,endPos) = getAbsoluteSegmentPos wire index if seg.Draggable then - let distanceToMove = + let distanceToMove = match getSegmentOrientation startPos endPos with | Horizontal -> mMsg.Pos.Y - startPos.Y | Vertical -> mMsg.Pos.X - startPos.X - let newWire = moveSegment model seg distanceToMove + let newWire = moveSegment model seg distanceToMove let newWires = Map.add seg.WireId newWire model.Wires { model with Wires = newWires } @@ -78,7 +78,7 @@ let newWire inputId outputId model = model, None else printfn "Separating new wire" - let newModel = + let newModel = model |> Optic.set (wireOf_ nWire.WId) nWire |> BusWireSeparate.updateWireSegmentJumpsAndSeparations [nWire.WId] @@ -94,7 +94,7 @@ let calculateBusWidths model = match connWidths[wire.WId] with | Some a -> a | None -> wire.Width - let newColor = + let newColor = if wire.Color = Purple || wire.Color = Brown then Purple else DarkSlateGrey wireMap.Add ( wire.WId, { wire with Width = width ; Color = newColor} ) @@ -109,7 +109,7 @@ let calculateBusWidths model = | Some 0 -> {symbol with InWidth0 = Some wire.Width} | x -> failwithf $"What? wire found with input port {x} other than 0 connecting to SplitWire" |> (fun sym -> Map.add symId sym m) - | SplitN _ -> + | SplitN _ -> match inPort.PortNumber with | Some 0 -> {symbol with InWidth0 = Some wire.Width} | x -> failwithf $"What? wire found with input port {x} other than 0 connecting to SplitN" @@ -121,19 +121,19 @@ let calculateBusWidths model = | Some 1 -> Map.add symId {symbol with InWidth1 = Some wire.Width} m | x -> failwithf $"What? wire found with input port {x} other than 0 or 1 connecting to MergeWires" - | MergeN nInps -> + | MergeN nInps -> match inPort.PortNumber with - | Some n when (n < nInps && n >= 0) -> - let newInWidths: int option list = + | Some n when (n < nInps && n >= 0) -> + let newInWidths: int option list = match symbol.InWidths with - | None -> List.init nInps (fun i -> + | None -> List.init nInps (fun i -> if i = n then Some wire.Width else None) - | Some list -> - match list.Length with + | Some list -> + match list.Length with | len when len = nInps -> - List.mapi (fun i x -> + List.mapi (fun i x -> if i = n then Some wire.Width else x) list - | _ -> List.init nInps (fun i -> + | _ -> List.init nInps (fun i -> if i = n then Some wire.Width else None) Map.add symId {symbol with InWidths = Some newInWidths} m | x -> failwithf $"What? wire found with input port {x} other than [0..{nInps-1}] connecting to MergeN" @@ -144,14 +144,14 @@ let calculateBusWidths model = let symbolsWithWidths = (model.Symbol.Symbols, newWires) ||> Map.fold addSymbolWidthFolder - + { model with - Wires = newWires; + Wires = newWires; Notifications = None; ErrorWires=[]; Symbol = {model.Symbol with Symbols = symbolsWithWidths} } - + let canvasState = (SymbolUpdate.extractComponents model.Symbol, extractConnections model) match BusWidthInferer.inferConnectionsWidth canvasState with @@ -173,13 +173,13 @@ let update (msg : Msg) (issieModel : ModelType.Model) : ModelType.Model*Cmd // add a newly created wire to the model // then send BusWidths message which will re-infer bus widths - // the new wires (extarcted as connections) are not added back into Issie model. + // the new wires (extarcted as connections) are not added back into Issie model. // This happens on save or when starting a simulation (I think) let newModel, msgOpt = newWire inputId outputId model {issieModel with Sheet={issieModel.Sheet with Wire=newModel}} |> (if msgOpt.IsSome then withMsg (Option.get msgOpt) else withNoMsg) - + | BusWidths -> let newModel, msgOpt = calculateBusWidths model toIssieModel newModel @@ -228,7 +228,7 @@ let update (msg : Msg) (issieModel : ModelType.Model) : ModelType.Model*Cmd) -> // record these wires in model.ErrorWires and highlight them as red. - // reset the wires that were remobed from model.ErrorWires dark grey + // reset the wires that were remobed from model.ErrorWires dark grey // (what if they are supposed to be something else?? Colors carry too muhc state!) let newWires = model.Wires @@ -243,7 +243,7 @@ let update (msg : Msg) (issieModel : ModelType.Model) : ModelType.Model*Cmd withNoMsg - | SelectWires (connectionIds : list) -> + | SelectWires (connectionIds : list) -> // selects all wires in connectionIds, and also deselects all other wires let newWires = model.Wires @@ -308,20 +308,20 @@ let update (msg : Msg) (issieModel : ModelType.Model) : ModelType.Model*Cmd fun model -> {issieModel with Sheet={ issieModel.Sheet with Wire=model}} |> withNoMsg - | ColorWires (connIds, color) -> + | ColorWires (connIds, color) -> // Just Changes the colour of the wires, Sheet calls pasteWires before this let newWires = (List.fold (fun prevWires cId -> let oldWireOpt = Map.tryFind cId model.Wires match oldWireOpt with - | None -> + | None -> prevWires | Some oldWire -> Map.add cId { oldWire with Color = color } prevWires) model.Wires connIds) {issieModel with Sheet={ issieModel.Sheet with Wire={ model with Wires = newWires }}} |> withNoMsg | ResetJumps connIds -> - // removes wire 'jumps' at start of drag operation for neater component movement + // removes wire 'jumps' at start of drag operation for neater component movement // without jump recalculation // makejumps at end of a drag operation restores new jumps let newModel = resetWireSegmentJumps connIds model @@ -336,27 +336,27 @@ let update (msg : Msg) (issieModel : ModelType.Model) : ModelType.Model*Cmd withNoMsg - | ResetModel -> + | ResetModel -> // How we start with nothing loaded {issieModel with Sheet={ issieModel.Sheet with Wire={ model with Wires = Map.empty; ErrorWires = []; Notifications = None }}} |> withNoMsg - | LoadConnections conns -> + | LoadConnections conns -> // we assume components (and hence ports) are loaded before connections // Issie connections are loaded as wires - // vertices on Issie connections contains routing info so wires can be + // vertices on Issie connections contains routing info so wires can be // reconstructed precisely /// check whether a laoded wires position matches a symbol vertex /// If the vertices lits is empty the evrtex will be None, and not match let posMatchesVertex (pos:XYPos) (vertexOpt: (float*float) option) = match vertexOpt with - | None -> + | None -> false | Some vertex -> let epsilon = Constants.vertexLoadMatchTolerance abs (pos.X - (fst vertex)) < epsilon && abs (pos.Y - (snd vertex)) < epsilon - + // get the newly loaded wires let newWires = conns @@ -368,7 +368,7 @@ let update (msg : Msg) (issieModel : ModelType.Model) : ModelType.Model*Cmd + | true -> posMatchesVertex (Symbol.getInputPortLocation None model.Symbol inputId) (List.tryLast conn.Vertices |> Option.map getVertex) @@ -382,7 +382,7 @@ let update (msg : Msg) (issieModel : ModelType.Model) : ModelType.Model*Cmd getOrientationOfEdge } |> makeWirePosMatchSymbol false @@ -421,10 +421,10 @@ let update (msg : Msg) (issieModel : ModelType.Model) : ModelType.Model*Cmd> = + let updatePortIdMessages: seq> = componentIds |> Symbol.getPortLocations model.Symbol - |> (fun (m1,m2) -> + |> (fun (m1,m2) -> let inputPorts = Seq.map (fun (InputPortId portId) -> portId) m1.Keys |> Seq.toList let outputPorts = Seq.map (fun (OutputPortId portId) -> portId) m2.Keys |> Seq.toList inputPorts @ outputPorts @@ -437,14 +437,14 @@ let update (msg : Msg) (issieModel : ModelType.Model) : ModelType.Model*Cmd Map.filter (fun _id wire -> + |> Map.filter (fun _id wire -> wire.InputPort = InputPortId portId || wire.OutputPort = OutputPortId portId) |> Map.toList @@ -457,11 +457,11 @@ let update (msg : Msg) (issieModel : ModelType.Model) : ModelType.Model*Cmd withNoMsg | ToggleSnapToNet -> {issieModel with Sheet={ issieModel.Sheet with Wire={model with SnapToNet = not model.SnapToNet}}} |> withNoMsg - -//---------------------------------------------------------------------------------// + +//---------------------------------------------------------------------------------// //---------------------------Other interface functions-----------------------------// -//---------------------------------------------------------------------------------// +//---------------------------------------------------------------------------------// /// Checks if a wire intersects a bounding box by checking if any of its segments intersect @@ -470,8 +470,8 @@ let wireIntersectsBoundingBox (wire : Wire) (box : BoundingBox) = let segmentIntersectsBox segStart segEnd state seg = match state with | Some x -> Some x - | None -> segmentIntersectsBoundingBox box segStart segEnd - + | None -> segmentIntersectsBoundingBoxDistance box segStart segEnd + foldOverSegs segmentIntersectsBox None wire /// Returns a list of wire IDs in the model that intersect the given selectBox @@ -503,7 +503,7 @@ let pasteWires (wModel : Model) (newCompIds : list) : (Model * list match SymbolUpdate.getEquivalentCopiedPorts wModel.Symbol oldCompIds newCompIds oldPorts with | Some (newInputPort, newOutputPort) -> - let portOnePos, portTwoPos = + let portOnePos, portTwoPos = Symbol.getTwoPortLocations wModel.Symbol (InputPortId newInputPort) (OutputPortId newOutputPort) let outputPortOrientation = getOutputPortOrientation wModel.Symbol (OutputPortId newOutputPort) let segmentList = makeInitialSegmentsList newId portOnePos portTwoPos outputPortOrientation diff --git a/src/Renderer/DrawBlock/BusWireUpdateHelpers.fs b/src/Renderer/DrawBlock/BusWireUpdateHelpers.fs index a7614228f..1953e13ba 100644 --- a/src/Renderer/DrawBlock/BusWireUpdateHelpers.fs +++ b/src/Renderer/DrawBlock/BusWireUpdateHelpers.fs @@ -15,17 +15,17 @@ open Operators //--------------------------------------------------------------------------------// //---------------------------getClickedSegment-----------------------------------// -/// Returns Some distance between a point and a segment defined by a start and end XYPos, +/// Returns Some distance between a point and a segment defined by a start and end XYPos, /// and None if the segment is of 0 length (can't be clicked) -let distanceBetweenPointAndSegment (segStart : XYPos) (segEnd : XYPos) (point : XYPos) : float option = +let distanceBetweenPointAndSegment (segStart : XYPos) (segEnd : XYPos) (point : XYPos) : float option = match squaredDistance segStart segEnd with | 0. -> None - | l2 -> + | l2 -> // Extend the segment to line segStart + t (segEnd - segStart) // The projection of point on this line falls at tProjection - let tProjection = dotProduct (point - segStart) (segEnd - segStart) / l2 + let tProjection = dotProduct (point - segStart) (segEnd - segStart) / l2 let tBounded = max 0. (min 1. tProjection) // Bound tProjection to be within the segment - let boundedProjection = + let boundedProjection = segEnd - segStart |> scalePos tBounded |> (+) segStart @@ -66,7 +66,7 @@ let getClickedSegment (model: Model) (wireId: ConnectionId) (mouse: XYPos) : ASe match foldOverNonZeroSegs closestSegment None model.Wires[wireId] with - | Some (segment, _dist) -> + | Some (segment, _dist) -> segment |> getAllSameNetASegments model mouse | None -> failwithf "getClosestSegment was given a wire with no segments" // Should never happen @@ -100,7 +100,7 @@ let getConnectedWireIds model compIds = |> List.map (fun wire -> wire.WId) /// Returns a list of wire IDs that meet the given condition -let getFilteredIdList condition wireLst = +let getFilteredIdList condition wireLst = wireLst |> List.filter condition |> List.map (fun wire -> wire.WId) @@ -139,11 +139,11 @@ let filterWiresByCompMoved (model: Model) (compIds: list) = // // WIRE NOTES // -// - The first and last segments of a wire (connected to the output and input ports) are called the 'nubs'. These have a minimum +// - The first and last segments of a wire (connected to the output and input ports) are called the 'nubs'. These have a minimum // length defined in Constants.nubLength, and are oriented perpendicular to the symbol edge (i.e. A nub for a port on the Right side // of a Symbol will be Horizontal). The initial positions and orientations of these nubs are defined in wire. Nubs cannot be dragged // -// - Additional segments are generated to route between the two nubs. The orientation of one segment will always be the +// - Additional segments are generated to route between the two nubs. The orientation of one segment will always be the // opposite of the previous. // // - To allow for any (non-nub) segments to be draggable, several segments of length 0 are inserted into the initial segment list. @@ -151,7 +151,7 @@ let filterWiresByCompMoved (model: Model) (compIds: list) = // - Both the start and end of the wire is defined to allow the wire to be processed from either direction. This is important because // routing is performed from the port that has been moved (i.e. if the input port has been moved we process from the end of the wire) // -// - Partial autorouting attempts to preserve manually routed segments when moving a port. The fixed point is defined as +// - Partial autorouting attempts to preserve manually routed segments when moving a port. The fixed point is defined as // the end of the first manually routed segment from the moved port. Partial autorouting can only be applied when // the position of the moved port relative to the fixed point is the same as before it was moved (see relativePosition). // @@ -165,26 +165,26 @@ let filterWiresByCompMoved (model: Model) (compIds: list) = /// TODO - this can maybe be simplified given we now coalesce segments let getSafeDistanceForMove (segments: Segment list) (index: int) (distance: float) = /// Returns a list of segments up to the first non-zero segment perpendicular to the segment leaving the port - let findBindingSegments portIndex segList = + let findBindingSegments portIndex segList = segList |> List.takeWhile (fun seg -> seg.Index % 2 = portIndex % 2 || seg.Length = 0) // Works for both input and output ports let findDistanceFromPort boundSegList = (0., boundSegList) ||> List.fold (fun dist seg -> dist + seg.Length) // Since the segments in perpendicular direction are 0 we can just sum up all the segments as if they are in the same direction - - let reduceDistance bindingSegs findBindingIndex distance = - if findBindingIndex bindingSegs <> index then + + let reduceDistance bindingSegs findBindingIndex distance = + if findBindingIndex bindingSegs <> index then distance else findDistanceFromPort bindingSegs - |> (fun dist -> - if sign dist = -1 then + |> (fun dist -> + if sign dist = -1 then max distance (dist + Constants.nubLength) - else + else min distance (dist - Constants.nubLength)) - let bindingInputSegs = + let bindingInputSegs = segments |> findBindingSegments 0 |> List.map (fun seg -> { seg with Length = -seg.Length}) @@ -216,8 +216,8 @@ let removeZeroSegment (segs: Segment list) indexToRemove = /// After coalescing a wire the wire ends may no longer be draggable. /// This function checks this and adds two segments to correct the problem /// if necessary. The added segments will not alter wire appearance. -/// The transformation is: -/// BEFORE: 1st seg length x. AFTER: 1st segment length nubLength -> zero-length seg +/// The transformation is: +/// BEFORE: 1st seg length x. AFTER: 1st segment length nubLength -> zero-length seg /// -> segment length x - nubLength let makeEndsDraggable (segments: Segment list): Segment list = let addNubIfPossible (segments: Segment list) = @@ -226,7 +226,7 @@ let makeEndsDraggable (segments: Segment list): Segment list = (segments.Length = 1 || not <| segments[1].IsZero) then let delta = float (sign segments[0].Length) * Constants.nubLength - let newSeg0 = {seg0 with Length = delta} + let newSeg0 = {seg0 with Length = delta} let newSeg1 = { seg0 with IntersectOrJumpList = []; Length = 0.; Draggable = true; Mode=Auto} let newSeg2 = {newSeg1 with Length = seg0.Length - delta} newSeg0 :: newSeg1 :: newSeg2 :: segments[1..] @@ -244,10 +244,10 @@ let makeEndsDraggable (segments: Segment list): Segment list = // Two parallel joined together segments can be made by having a zero-length segment in the middle. // After snapping, this case is quite common (and the zero-length segment will be exactly zero). // This motovates coalescing segments to make longer ones where possible. -// In addition, to make the ends of a wire draggable the two end segments, if not short, need to be +// In addition, to make the ends of a wire draggable the two end segments, if not short, need to be // made as a short non-draggable 'nub' connected to the port, followed by a parallel, variable-length segment. // The end three segments are therefore: nub / 0 length / rest of 1st visible segment. -// Finally, the visible segment from a port must emerge outwards. So coalescing a numb +// Finally, the visible segment from a port must emerge outwards. So coalescing a numb // (which is always outwards direction) with an opposite direction segment is not allowed. @@ -261,24 +261,24 @@ let coalesceInWire (wId: ConnectionId) (model:Model) = //printfn $"Before coalesce, seg lengths: {segments |> List.map (fun seg -> seg.Length)}" let segmentsToRemove = List.indexed segments - |> List.filter (fun (i,seg) -> + |> List.filter (fun (i,seg) -> segments[i].IsZero && i > 1 && i < segments.Length - 2 && segments[i-1].Draggable && segments[i+1].Draggable) |> List.map (fun (index,_) -> index) |> List.sortDescending // needed if more than one segment can be removed - not sure this can happen! let newSegments = - let opposite seg1 seg2 = + let opposite seg1 seg2 = match sign seg1.Length, sign seg2.Length with | 1, -1 | -1, 1 -> true - | _ -> false + | _ -> false (segments, segmentsToRemove) ||> List.fold removeZeroSegment - |> (fun segments' -> - if opposite segments[0] segments'[0] + |> (fun segments' -> + if opposite segments[0] segments'[0] || opposite segments[segments.Length-1] segments'[segments'.Length-1] then segments - else + else segments') |> makeEndsDraggable @@ -299,10 +299,10 @@ let resetWireToAutoKeepingPositionOpt (wire: Wire) : Wire option= |> Some | false -> None -/// Returns a wwireOf_aining the updated list of segments after a segment is moved by +/// Returns a wwireOf_aining the updated list of segments after a segment is moved by /// a specified distance. The moved segment is tagged as manual so that it is no longer auto-routed. /// Throws an error if the index of the segment being moved is not a valid movable segment index. -let moveSegment (model:Model) (seg:Segment) (distance:float) = +let moveSegment (model:Model) (seg:Segment) (distance:float) = let wire = model.Wires[seg.WireId] let segments = wire.Segments let idx = seg.Index @@ -312,7 +312,7 @@ let moveSegment (model:Model) (seg:Segment) (distance:float) = wire else let safeDistance = getSafeDistanceForMove segments idx distance - + let prevSeg = segments[idx - 1] let nextSeg = segments[idx + 1] let movedSeg = segments[idx] @@ -320,8 +320,8 @@ let moveSegment (model:Model) (seg:Segment) (distance:float) = let newPrevSeg = { prevSeg with Length = prevSeg.Length + safeDistance } let newNextSeg = { nextSeg with Length = nextSeg.Length - safeDistance } let newMovedSeg = { movedSeg with Mode = Manual } - - let newSegments = + + let newSegments = segments[.. idx - 2] @ [newPrevSeg; newMovedSeg; newNextSeg] @ segments[idx + 2 ..] { wire with Segments = newSegments } @@ -341,7 +341,7 @@ let inline genPortInfo edge position = { Edge = edge; Position = position } /// Returns an edge rotated 90 degrees anticlockwise -let inline rotate90Edge (edge: Edge) = +let inline rotate90Edge (edge: Edge) = match edge with | CommonTypes.Top -> CommonTypes.Left | CommonTypes.Left -> CommonTypes.Bottom @@ -358,7 +358,7 @@ let inline rotate90Port (port: PortInfo) = genPortInfo newEdge newPos -/// Returns a function to rotate a segment list 90 degrees about the origin, +/// Returns a function to rotate a segment list 90 degrees about the origin, /// depending on its initial orientation let rotateSegments90 initialOrientation = let horizontal i = @@ -376,7 +376,7 @@ let rotateSegments90 initialOrientation = >> List.map rotateSegment /// Returns a version of the start and destination ports rotated until the start edge matches the target edge. -let rec rotateStartDest (target: Edge) ((start, dest): PortInfo * PortInfo) = +let rec rotateStartDest (target: Edge) ((start, dest): PortInfo * PortInfo) = if start.Edge = target then (start, dest) else @@ -384,12 +384,12 @@ let rec rotateStartDest (target: Edge) ((start, dest): PortInfo * PortInfo) = /// Gets a wire orientation given a port edge -let inline getOrientationOfEdge (edge: Edge) = +let inline getOrientationOfEdge (edge: Edge) = match edge with | CommonTypes.Top | CommonTypes.Bottom -> Vertical | CommonTypes.Left | CommonTypes.Right -> Horizontal -/// Returns an anonymous record containing the starting symbol edge of a wire and its segment list that has been +/// Returns an anonymous record containing the starting symbol edge of a wire and its segment list that has been /// rotated to a target symbol edge. let rec rotateSegments (target: Edge) (wire: {| edge: Edge; segments: Segment list |}) = if wire.edge = target then @@ -397,9 +397,9 @@ let rec rotateSegments (target: Edge) (wire: {| edge: Edge; segments: Segment li else let rotatedSegs = rotateSegments90 (getOrientationOfEdge wire.edge) wire.segments - + {| edge = rotate90Edge wire.edge; segments = rotatedSegs |} - |> rotateSegments target + |> rotateSegments target /// Returns a newly autorouted version of a wire for the given model let autoroute (model: Model) (wire: Wire) : Wire = @@ -414,9 +414,9 @@ let autoroute (model: Model) (wire: Wire) : Wire = let startPort = genPortInfo startEdge startPos let destPort = genPortInfo destEdge destPos - + // Normalise the routing problem to reduce the number of cases in makeInitialSegmentsList - let normStart, normEnd = + let normStart, normEnd = rotateStartDest CommonTypes.Right (startPort, destPort) let initialSegments = @@ -441,10 +441,10 @@ let autoroute (model: Model) (wire: Wire) : Wire = /// Returns an anonymous record indicating the position of pos relative to origin. /// The isAbove field indicates whether pos is above (true) or below (false) origin. /// The isLeft field indicates whether pos is to the left (true) or to the right (false) of origin. -let relativePosition (origin: XYPos) (pos:XYPos) = +let relativePosition (origin: XYPos) (pos:XYPos) = {| isLeft = origin.X > pos.X; isAbove = origin.Y > pos.Y |} -/// Returns the tuple (startPos, endPos) of the segment at the target index in the given wire. +/// Returns the tuple (startPos, endPos) of the segment at the target index in the given wire. /// Throws an error if the target index isn't found. let getAbsoluteSegmentPos (wire: Wire) (target: int) = (None, wire) @@ -453,11 +453,17 @@ let getAbsoluteSegmentPos (wire: Wire) (target: int) = if seg.Index = target then Some (startPos, endPos) else state) |> (function | None -> failwithf $"Couldn't find index {target} in wire" - | Some pos -> pos) + | Some pos -> pos) -/// Returns the length to change a segment represented by startPos -> endPos +/// Returns the length to change a segment represented by startPos -> endPos /// in the appropriate dimension of the difference vector. let getLengthDiff difference startPos endPos = + /// Returns the X-value of an XYPos + let inline toX (pos: XYPos) = pos.X + + /// Returns the Y-value of an XYPos + let inline toY (pos: XYPos) = pos.Y + match getSegmentOrientation startPos endPos with | Horizontal -> toX difference | Vertical -> toY difference @@ -489,26 +495,26 @@ let partitionSegments segs manualIdx = | _ -> List.splitAt (manualIdx - 1) segs let changed, remaining = List.splitAt 2 tmp - if (start @ changed @ remaining).Length <> segs.Length then + if (start @ changed @ remaining).Length <> segs.Length then printfn $"Bad partial routing partition: index=\ {manualIdx}:{start.Length},{changed.Length},{remaining.Length} ({segs.Length})" (start, changed, remaining) /// Returns None if full autoroute is required or applies partial autorouting -/// from the start of the wire at newPortPos to the first manually routed segment +/// from the start of the wire at newPortPos to the first manually routed segment /// and returns Some wire with the new segments. -let partialAutoroute (model: Model) (wire: Wire) (newPortPos: XYPos) (reversed: bool)= +let partialAutoroute (model: Model) (wire: Wire) (newPortPos: XYPos) (reversed: bool)= let segs = wire.Segments let newWire = { wire with StartPos = newPortPos } - /// Returns the manual index and change in port position + /// Returns the manual index and change in port position /// if partial routing can be performend, else none let eligibleForPartialRouting manualIdx = let oldStartPos = getPartialRouteStart wire manualIdx let newStartPos = getPartialRouteStart newWire manualIdx let fixedPoint = getAbsoluteSegmentPos wire manualIdx |> snd let relativeToFixed = relativePosition fixedPoint - let portId = + let portId = match reversed with | false -> OutputId wire.OutputPort | true -> InputId wire.InputPort @@ -519,32 +525,32 @@ let partialAutoroute (model: Model) (wire: Wire) (newPortPos: XYPos) (reversed: Some (manualIdx, newStartPos - oldStartPos, portOrientation) else None - + /// Returns the partially routed segment list let updateSegments (manualIdx, diff, portOrientation) = /// consistency check not needed (does it work? let segsRetracePath (segs: Segment list) = [1..segs.Length-2] - |> List.exists (fun i -> - segs[i].IsZero + |> List.exists (fun i -> + segs[i].IsZero && sign segs[i-1].Length <> sign segs[i+1].Length && not segs[i-1].IsZero && not segs[i+1].IsZero) let start, changed, remaining = partitionSegments segs manualIdx - let changed' = + let changed' = changed - |> List.map (fun seg -> + |> List.map (fun seg -> let (startPos, endPos) = getAbsoluteSegmentPos wire seg.Index { seg with Length = seg.Length - getLengthDiff diff startPos endPos }) start @ changed' @ remaining - |> (fun segs -> + |> (fun segs -> let wire' = {wire with Segments = segs; StartPos = newPortPos} //wire' match getWireOutgoingEdge wire' = portOrientation (*|| not (segsRetracePath segs)*) with | true -> Some wire' | false -> None) - + segs |> getManualIndex |> Option.bind eligibleForPartialRouting @@ -574,7 +580,7 @@ let reverseWire (wire: Wire) = -/// Returns an updated wireMap with the IntersectOrJumpList of targetSeg +/// Returns an updated wireMap with the IntersectOrJumpList of targetSeg /// replaced by jumps or modern intersections. let updateSegmentJumpsOrIntersections targetSeg intersectOrJump wireMap = let wId = targetSeg.WireId @@ -594,7 +600,7 @@ let updateSegmentJumpsOrIntersections targetSeg intersectOrJump wireMap = /// TODO - replace Index by Segment. type SegInfo = {P: float; Qmin: float; Qmax:float; Index: int; OfWire: Wire} -/// get segments on wire partitioned horizontal and vertical. +/// get segments on wire partitioned horizontal and vertical. /// small length segments are not included, since this is to determine modern circle placement let getHVSegs (wire : Wire) = let isHorizontal (seg:ASegment) = @@ -602,7 +608,7 @@ let getHVSegs (wire : Wire) = match wire.InitialOrientation with | Horizontal -> index % 2 = 0 | Vertical -> index % 2 = 1 - + let makeInfo p q1 q2 (i:int) (seg:ASegment) = let qMin = min q1 q2 @@ -621,9 +627,9 @@ let getHVSegs (wire : Wire) = type CircleT = float * int * Wire let resetWireJumpsOrIntersections (wire:Wire) = - let newSegments = + let newSegments = wire.Segments - |> List.map (fun seg -> + |> List.map (fun seg -> {seg with IntersectOrJumpList=[]}) {wire with Segments = newSegments} @@ -634,24 +640,24 @@ let resetModelJumpsOrIntersections (model: Model) : Model = |> Map.map (fun _ w -> resetWireJumpsOrIntersections w) {model with Wires = newWires} -let updateCirclesOnSegments +let updateCirclesOnSegments (wiresToUpdate: Wire list) - (circles: CircleT list) + (circles: CircleT list) (model: Model) = (model.Wires, wiresToUpdate) ||> List.fold (fun wires wire -> let wire = wires[wire.WId] - let findAllCirclesOnWire circles = + let findAllCirclesOnWire circles = List.filter (fun ((_,_,wire'): CircleT) -> wire'.WId = wire.WId) circles let newWire = (wire, findAllCirclesOnWire circles) - ||> List.fold (fun wire (cPos,cIndex, _) -> + ||> List.fold (fun wire (cPos,cIndex, _) -> let seg = wire.Segments[cIndex] let seg' = {seg with IntersectOrJumpList = cPos::seg.IntersectOrJumpList} {wire with Segments = List.updateAt cIndex seg' wire.Segments}) Map.add wire.WId newWire wires) - |> (fun wires -> {model with Wires = wires}) + |> (fun wires -> {model with Wires = wires}) let inline samePos (pos1: XYPos) (pos2: XYPos) = max (pos1.X-pos2.X) (pos1.Y - pos2.Y) < Constants.modernCirclePositionTolerance @@ -661,7 +667,7 @@ let inline closeBy (d:float) (a:float) (b:float) = abs (a-b) < d let inline close (a:float) (b:float) = abs (a-b) < Constants.modernCirclePositionTolerance /// Update all the modern routing circles on the net of wires: wiresInNet -let updateCirclesOnNet +let updateCirclesOnNet (model: Model) (wiresInNet: Wire list) : Model = let hsL, vsL = @@ -684,7 +690,7 @@ let updateCirclesOnNet |> List.collect (fun (s1, s2) -> if close s1.P s2.P && close s1.Qmax s2.Qmin then [{|P=(s1.P+s2.P)/2.;Q=(s1.Qmax+s2.Qmin)/2.; Index=s2.Index; Wire=s2.OfWire|}] - else + else []) /// get all intersections - circles will be placed here let intersectCircles = @@ -696,23 +702,23 @@ let updateCirclesOnNet |> List.collect (fun join -> if List.exists (fun vs -> close vs.P join.Q && (close vs.Qmin join.P || close vs.Qmax join.P)) vsL then [join.Q,join.Index,join.Wire] - else + else []) /// all vertical join circles let vJoinCircles = getJoins vsL |> List.collect (fun join -> - hsL - |> List.tryPick (fun hs -> + hsL + |> List.tryPick (fun hs -> if close hs.P join.Q && (close hs.Qmin join.P || close hs.Qmax join.P) then Some [join.P, hs.Index, hs.OfWire] - else + else None) |> Option.defaultValue []) let circles = intersectCircles @ vJoinCircles @ hJoinCircles model |> updateCirclesOnSegments wiresInNet circles -/// Update all the modern routing circles in the model +/// Update all the modern routing circles in the model let updateCirclesOnAllNets (model:Model) = let cleanModel = model @@ -720,7 +726,7 @@ let updateCirclesOnAllNets (model:Model) = /// A net is a set of electrically connected wires. /// For now this is all wires with given port as source /// TODO: join nets which are on same wire label. - let nets = + let nets = partitionWiresIntoNets cleanModel |> List.map snd |> List.map (List.map snd) @@ -728,10 +734,10 @@ let updateCirclesOnAllNets (model:Model) = ||> List.fold updateCirclesOnNet /// Used as a folder in foldOverSegs. Finds all jump offsets in a wire for the segment defined in the state -let inline findJumpIntersects - (segStart: XYPos) - (segEnd: XYPos) - (state: {| Start: XYPos; End: XYPos; JumpsOrIntersections: float list |}) +let inline findJumpIntersects + (segStart: XYPos) + (segEnd: XYPos) + (state: {| Start: XYPos; End: XYPos; JumpsOrIntersections: float list |}) (seg: Segment) = if getSegmentOrientation segStart segEnd = Vertical then let xVStart, xHStart, xHEnd = segStart.X, state.Start.X, state.End.X @@ -743,7 +749,7 @@ let inline findJumpIntersects {| state with JumpsOrIntersections = abs (xVStart - xHStart) :: state.JumpsOrIntersections |} else state - else + else state /// Returns a model with all the jumps updated @@ -757,33 +763,33 @@ let makeAllJumps (wiresWithNoJumps: ConnectionId list) (model: Model) = let updateJumpsInWire (segStart: XYPos) (segEnd: XYPos) (wireMap: Map) (seg: Segment) = if getSegmentOrientation segStart segEnd = Horizontal then ([], wires) - ||> Array.fold (fun jumpsOrIntersections wire -> + ||> Array.fold (fun jumpsOrIntersections wire -> if (model.Type = Jump) then foldOverSegs findJumpIntersects {| Start = segStart; End = segEnd; JumpsOrIntersections = [] |} wire |> (fun res -> res.JumpsOrIntersections) |> List.append jumpsOrIntersections - else + else jumpsOrIntersections) - |> (fun jumpsOrIntersections -> + |> (fun jumpsOrIntersections -> if jumpsOrIntersections <> seg.IntersectOrJumpList then updateSegmentJumpsOrIntersections seg jumpsOrIntersections wireMap - else + else wireMap) else wireMap match model.Type with | Jump -> - let wiresWithJumps = + let wiresWithJumps = (model.Wires, wires) ||> Array.fold (fun map wire -> foldOverSegs updateJumpsInWire map wire) - + { model with Wires = wiresWithJumps } | Modern -> printfn "Updating modern circles" updateCirclesOnAllNets model - | Radial -> + | Radial -> model let updateWireSegmentJumps (wireList: list) (model: Model) : Model = @@ -817,26 +823,26 @@ let deleteWiresWithPort (delPorts: Port option list) (model: Model) = match delPorts with |[] -> model - |_ -> + |_ -> let wires = model.Wires |> Map.toList - let ports, symbols, connIds = + let ports, symbols, connIds = ((model.Symbol.Ports, model.Symbol.Symbols,[]), delPorts) ||> List.fold (fun (ports,symbols,conns) p -> match p with |Some port -> - let localConns = + let localConns = wires |> List.filter (fun (connId,wire) -> ((wire.InputPort.ToString() = port.Id) || (wire.OutputPort.ToString() = port.Id))) |> List.map fst let symbols = - Map.tryFind (ComponentId port.HostId) symbols + Map.tryFind (ComponentId port.HostId) symbols |> Option.map (fun sym -> let sym' = {sym with PortMaps = Symbol.deletePortFromMaps port.HostId sym.PortMaps} Map.add (ComponentId port.HostId) sym' symbols) |> Option.defaultValue symbols let ports = Map.remove port.Id ports ports, symbols, conns@localConns - |None -> ports, symbols,conns + |None -> ports, symbols,conns ) model |> Optic.set (DrawModelType.BusWireT.symbol_ >-> symbols_) symbols @@ -846,6 +852,6 @@ let deleteWiresWithPort (delPorts: Port option list) (model: Model) = (wires, connIds) ||> List.fold (fun wires connId -> Map.remove connId wires) |> (fun wires -> printf $"{wires.Count} wires after deletion"; wires)) - + diff --git a/src/Renderer/DrawBlock/IntersectionHelpers.fs b/src/Renderer/DrawBlock/IntersectionHelpers.fs new file mode 100644 index 000000000..013b1dc88 --- /dev/null +++ b/src/Renderer/DrawBlock/IntersectionHelpers.fs @@ -0,0 +1,505 @@ +module IntersectionHelpers + +open EEExtensions + +open DrawModelType +open CommonTypes +open DrawModelType.SheetT +open DrawModelType.BusWireT +open Optics +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 SymbolPortHelpers +open Sheet +// --------------------------------------------------- // +// 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-----------------------------------// + +/// 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 + + /// Returns segment orientation of a visual segment. + /// Input must be a pair of visual segment vertices (start, end). + 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 printVisSeg (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}-" + + /// Return a list of visible segments in a wire as a pair (start,end) of vertices. + /// start is the segment end closest to the wire Source. + /// Input is a wire and the model. + 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 + /// KeepBothIfDifferentLength = true => keep overlapping segments that share the same end point. + // tdc21: added keepBothIfDifferentLength for HLP24 T5R spec. + let distinctVisSegs (keepBothIfDifferentLength: 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 keepBothIfDifferentLength 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. + /// There is no implementation for keepBothIfDifferentLength, so it is always false, + /// i.e. the function keeps segments that have a distinct start point and orientation, disregarding the end point. + /// 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 + /// keepBothIfDifferentLength = true => keep overlapping segments that share the same end point. + // tdc21: added keepBothIfDifferentLength to allow for the removal of overlapping segments that share the same end point. Useful for HLP24 T5R spec. + + let getVisualSegsFromNetWires (isDistinct: bool) (keepBothIfDifferentLength: bool) (model: SheetT.Model) netWires = + netWires + |> List.collect (fun wire -> visibleSegsWithVertices wire model) + |> (if isDistinct then + (distinctVisSegs keepBothIfDifferentLength) + 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) // +// --------------------------------------------------- // +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 +// tdc21: added keepBothIfDifferentLength to allow for the removal of overlapping segments that share the same end point. +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 -> + segmentIntersectsBoundingBoxDistance box aSeg.Start aSeg.End + |> Option.isSome) + + let retracingSegsInsideSymbol = + retracingSegs + |> List.filter checkSegIntersectsAnySymbol + + {| RetraceSegs = retracingSegs + RetraceSegsInSymbol = retracingSegsInsideSymbol |} + +// -------------------------------------------------------- // +// Helpers for D1 HLP2024(sheet align scale) // +// -------------------------------------------------------- // + + +/// Given a list, unzip it into two lists, one containing the odd-indexed elements and the other containing the even-indexed elements. +let unzipIntoOddAndEvenElems list = + list + |> List.mapi (fun i x -> (i % 2 = 0, x)) + |> List.partition fst + |> fun (odd, even) -> (List.map snd odd, List.map snd even) + + +/// For a given wire, checks if the wire is almost straight. +/// The threshold is the maximum deviation length (in the minority direction) that a wire can have, to be considered almost straight. +let checkAlmostStraightWire (wire: BusWireT.Wire) (model: Model) (maxDeviationLengthThreshold: float ): bool = + let visibleSegs = + visibleSegsWithVertices wire model + |> List.map (fun (startPos: XYPos, endPos: XYPos) -> ((euclideanDistance startPos endPos), startPos, endPos )) + + match (visibleSegs.Length > 2) && ((visibleSegs.Length % 2) <> 0) with + | true -> + let oddList, evenList = unzipIntoOddAndEvenElems visibleSegs + + let oddDisplacement = + oddList + |> List.sumBy (fun (segLength, _, _) -> segLength) + + let evenDisplacement = + evenList + |> List.sumBy (fun (segLength, _, _) -> segLength) + + // wire is travelling in majority direction if oddDisplacement >= evenDisplacement. + // its majority direction will be the direction of its odd segments, and minority direction will be the direction of its even segments + match oddDisplacement >= evenDisplacement with + | true -> + let maxDeviationLength = evenList + |> List.maxBy (fun (segLength, _,_) -> abs segLength) + |> fun (segLength, _,_) -> segLength + abs (maxDeviationLength) < maxDeviationLengthThreshold + | false -> false + + | false -> false + +/// Function that counts the number of almost straight wires on the sheet, given a threshold. +/// The threshold is the maximum deviation length (in the minority direction) that a wire can have, to be considered almost straight. +let countAlmostStraightWiresOnSheet (sheetModel: SheetT.Model) (maxDeviationLengthThreshold: float): int = + let straightWires = + sheetModel.Wire.Wires + |> Map.filter (fun _ wire -> checkAlmostStraightWire wire sheetModel maxDeviationLengthThreshold) + straightWires.Count + + +// ----------------------------------------------------------- // +// Note: Looking for more helpers that take in a wire and // +// output a port/symbol? Look in BlockHelpers // +// ----------------------------------------------------------- // + +/// (new!) tdc21: Helper function that returns the wires connected to an output port id net +let getWiresFromPortOutputNet (sourcePort: OutputPortId) (model: SheetT.Model): Wire list = + model.Wire.Wires + |> Map.filter (fun _ wire -> wire.OutputPort = sourcePort) + |> Map.values + |> Array.toList + +/// (new!) tdc21: Helper function that returns the wire connected to an input port id. +/// Since only one wire can be connected to an input port, it returns one wire. +let getWireFromPortInput (inputPort: InputPortId) (model: SheetT.Model): Wire = + model.Wire.Wires + |> Map.filter (fun _ wire -> wire.InputPort = inputPort) + |> Map.values + |> Array.toList + |> List.head + +/// (new!) tdc21: Helper function that returns the wires connected to a symbol +/// Returns a record with the input wires, output wires and the total count of wires connected to the symbol +let getWiresConnectedToSymbol (sym: Symbol) (model: SheetT.Model) : {|InputWires: Wire list; OutputWires: Wire list; Count : int|} = + let inputWires = + sym.Component.InputPorts + |> List.collect (fun (port: Port) -> [ getWireFromPortInput (InputPortId port.Id) model] ) + let outputWires = + sym.Component.OutputPorts + |> List.collect (fun (port: Port) -> getWiresFromPortOutputNet (OutputPortId port.Id) model) + + {|InputWires = inputWires; OutputWires = outputWires; Count = ((List.length inputWires) + (List.length outputWires)) |} + +/// (new!) tdc21: Helper function that returns the symbol that contains a given portId +/// If the portId is not found, returns None +let getSymbolFromPortId (portId: string) (model: SheetT.Model) : Symbol Option = + let foundPort = + model.Wire.Symbol.Ports + |> Map.tryFind portId + + match foundPort with + | Some port -> Map.tryFind (ComponentId port.HostId) model.Wire.Symbol.Symbols + | None -> None + + +/// (new!) tdc21: Helper function that checks if a wire is singly connected +let checkIfSinglyConnected (wire: Wire) (model:SheetT.Model)= + let inputSymbol = getSourceSymbol model.Wire wire + let outputSymbol = getTargetSymbol model.Wire wire + + if (getWiresConnectedToSymbol inputSymbol model).Count = 1 || (getWiresConnectedToSymbol outputSymbol model).Count = 1 then + true + else + false + +/// (new!) tdc21: Function that counts the number of singly connected wires on the sheet +let countSinglyConnectedWires (model: SheetT.Model): int = + model.Wire.Wires + |> Map.filter (fun _ wire -> checkIfSinglyConnected wire model) + |> Map.count + +/// (new!) tdc21: Helper that finds symbols on either ends of a wire. Returns a record of the input port, input symbol option, output port and output symbol option +let getSymbolsOnWireEnds (wire: Wire) (model: SheetT.Model) : {|InputPort: InputPortId; InputPortSymbol: Symbol; OutputPort: OutputPortId; OutputPortSymbol: Symbol|}= + let inputSymbol = getSourceSymbol model.Wire wire + let outputSymbol = getTargetSymbol model.Wire wire + + {|InputPort=wire.InputPort; InputPortSymbol = inputSymbol; OutputPort=wire.OutputPort; OutputPortSymbol = outputSymbol|} + + + + + + + + + + + + + + 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..9f549727c 100644 --- a/src/Renderer/DrawBlock/SheetDisplay.fs +++ b/src/Renderer/DrawBlock/SheetDisplay.fs @@ -1,4 +1,5 @@ module SheetDisplay + open CommonTypes open Fable.React open Fable.React.Props @@ -8,9 +9,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 +41,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 +67,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 +92,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 +127,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 +175,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 +229,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 +255,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 +276,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 +328,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/SheetUpdateHelpers.fs b/src/Renderer/DrawBlock/SheetUpdateHelpers.fs index 3fecd361d..013a95593 100644 --- a/src/Renderer/DrawBlock/SheetUpdateHelpers.fs +++ b/src/Renderer/DrawBlock/SheetUpdateHelpers.fs @@ -1,4 +1,6 @@ -module SheetUpdateHelpers +/// Helpers that are called in SheetUpdate.fs when updating the Sheet in response to messages of type SheetT.Msg +/// For more information, see DrawModelType.SheetT +module SheetUpdateHelpers open CommonTypes open Elmish @@ -16,11 +18,12 @@ open Browser open Optics open Operators +/// Given a model, simulate CtrlW press event to fit the circuit to the screen let fitCircuitToScreenUpdate (model: Model) = let model', paras = fitCircuitToWindowParas model printf "CtrlW Calculated Scroll = %A" paras.Scroll - model', - Cmd.batch + model', + Cmd.batch [ sheetCmd (SheetT.Msg.UpdateScrollPos paras.Scroll) sheetCmd SheetT.Msg.UpdateBoundingBoxes @@ -28,35 +31,41 @@ let fitCircuitToScreenUpdate (model: Model) = sheetCmd (SheetT.Msg.KeyPress CtrlW) ] +/// Given a symbol, return the symbol with a rotated label that is updated to match the symbol's rotation let rotateLabel (sym:Symbol) = let newRot = Option.defaultValue Degree0 sym.LabelRotation |> Symbol.combineRotation Degree270 |> Some - - {sym with + + {sym with LabelRotation = newRot LabelHasDefaultPos = true} +/// Given a model, rotate its selected symbols' labels clockwise let rotateSelectedLabelsClockwise (model:Model) = let symMap = model.Wire.Symbol.Symbols - let syms = + let syms = model.SelectedComponents |> List.map(fun compId -> symMap[compId]) - + (symMap, syms) - ||> List.fold (fun sMap sym -> + ||> List.fold (fun sMap sym -> Map.add sym.Id ((rotateLabel >> Symbol.calcLabelBoundingBox) sym) sMap) |> (fun sMap -> Optic.set symbols_ sMap model, Cmd.none) +/// Determines the orientation of a bounding box based on its width and height, accoridng to boxAspectRatio defined in Constants (Sheet.fs module) +/// Returns a tuple with the orientation (Horizontal or Vertical) and the aspect ratio if the bounding box meets certain conditions. let bbOrientation (bb: BoundingBox) = let ratio = Constants.boxAspectRatio + // add 0.1 to avoid division by zero match abs bb.W > ratio*abs bb.H, abs bb.H > ratio*abs bb.W with | true, false when abs bb.W > 10. -> Some (Horizontal, abs bb.W / (abs bb.H+0.1)) | false, true when abs bb.H > 10. -> Some (Vertical, abs bb.H / (abs bb.W + 0.1)) | _ -> None + let workOutArrangement (arrange: Arrange) (syms: Symbol list) = syms |> List.groupBy symbolMatch @@ -66,7 +75,7 @@ let workOutArrangement (arrange: Arrange) (syms: Symbol list) = |> List.tryHead |> Option.map (fun (syms,bbData) -> match syms, bbData, arrange with - | [], _, _-> + | [], _, _-> [], Error "No alignable symbols found" | syms, Some(orient,_), DistributeSymbols when syms.Length < 3 -> syms, Error "3 or more symbols of the same type are needed to distribute" @@ -78,27 +87,30 @@ let workOutArrangement (arrange: Arrange) (syms: Symbol list) = - +/// Project the X coordinate of a XYPos if isX is true, otherwise project the Y coordinate let projectXY isX (pos: XYPos) = match isX with | true -> pos.X | false -> pos.Y +/// Inject a new value into the X or Y coordinate of a XYPos if isX is true, otherwise inject into the Y coordinate let injectXY isX f (pos:XYPos) = match isX with | true -> {pos with X = f} | false -> {pos with Y = f} + let alignPosition (symbols: Symbol list) (isX: bool) = symbols |> List.map (Symbol.getRotatedSymbolCentre >> projectXY isX) - |> (fun lst -> + |> (fun lst -> let av = List.sum lst / float lst.Length - List.zip lst symbols - |> List.collect (fun (c,sym) -> + List.zip lst symbols + |> List.collect (fun (c,sym) -> let offset = av - c [ Symbol <| MoveSymbols([sym.Id], injectXY isX offset {X=0;Y=0}) BusWireT.UpdateSymbolWires sym.Id ])) +/// Aligns the position of symbols either horizontally or vertically based on the specified axis. let distributePosition (symbols: Symbol list) (isX: bool) = symbols |> List.map (Symbol.getRotatedSymbolCentre >> projectXY isX) @@ -107,7 +119,7 @@ let distributePosition (symbols: Symbol list) (isX: bool) = let incr = (maxF - minF) / ((float lst.Length) - 1.) List.zip lst symbols |> List.sortBy fst - |> List.mapi (fun i (f,sym) -> + |> List.mapi (fun i (f,sym) -> let offset = injectXY isX (minF + (float i)*incr - f ) {X=0;Y=0} [ Symbol <| MoveSymbols ([sym.Id], offset) @@ -115,26 +127,27 @@ let distributePosition (symbols: Symbol list) (isX: bool) = ]) |> List.concat) +/// Arranges the selected symbols in the model based on the specified arrangement (alignment or distribution) let arrangeSymbols (arrange: Arrange) (model:Model) : Model * Cmd = let syms, result = model.SelectedComponents |> List.map (fun sId -> model.Wire.Symbol.Symbols[sId]) |> workOutArrangement arrange - let newSelected = + let newSelected = syms |> List.map (fun sym -> ComponentId sym.Component.Id) match result with - | Error _mess -> + | Error _mess -> {model with SelectedComponents = newSelected}, Cmd.none | Ok orientation -> - let postludeCmds = [ - sheetCmd UpdateBoundingBoxes; + let postludeCmds = [ + sheetCmd UpdateBoundingBoxes; ] let cmds = match arrange with - | AlignSymbols -> + | AlignSymbols -> alignPosition syms (orientation = Vertical) - | DistributeSymbols -> - distributePosition syms (orientation = Horizontal) + | DistributeSymbols -> + distributePosition syms (orientation = Horizontal) |> List.map (Wire >> sheetCmd) Optic.set selectedComponents_ newSelected model, (Cmd.batch (cmds @ postludeCmds)) @@ -148,7 +161,7 @@ let moveSymbols (model: Model) (mMsg: MouseT) = match model.SelectedComponents with | [] -> model, Cmd.none | [symId] -> // Attempt Snap-to-Grid if there is only one moving component - let symbol = + let symbol = match Map.tryFind symId model.Wire.Symbol.Symbols with | Some symbol -> symbol | None -> @@ -174,10 +187,10 @@ let moveSymbols (model: Model) (mMsg: MouseT) = | _ -> // Moving multiple symbols -> don't do snap-to-grid let errorComponents = model.SelectedComponents - |> List.filter (fun sId -> not (notIntersectingComponents model model.BoundingBoxes[sId] sId)) + |> List.filter (fun sId -> not (notIntersectingComponents model model.BoundingBoxes[sId] sId)) {model with Action = nextAction; - LastMousePos = mMsg.Pos; - ScrollingLastMousePos = {Pos=mMsg.Pos;Move=mMsg.ScreenMovement}; + LastMousePos = mMsg.Pos; + ScrollingLastMousePos = {Pos=mMsg.Pos;Move=mMsg.ScreenMovement}; ErrorComponents = errorComponents}, Cmd.batch [ symbolCmd (SymbolT.MoveSymbols (model.SelectedComponents, mMsg.Pos - model.LastMousePos)) symbolCmd (SymbolT.ErrorSymbols (errorComponents,model.SelectedComponents,isDragAndDrop)) @@ -189,12 +202,12 @@ let moveSymbols (model: Model) (mMsg: MouseT) = /// Performs the Segment Drag operation implementing snaps. /// This function must be in update and creates additional commands /// to implement the drag oeporation. -let snapWire - (model: Model) - (mMsg: MouseT) +let snapWire + (model: Model) + (mMsg: MouseT) (segIdL: SegmentId list) - : Model * Cmd = - + : Model * Cmd = + let nextAction, isMovingWire = match model.Action with | MovingWire segId -> MovingWire segId, true @@ -213,8 +226,8 @@ let snapWire let aSegment = BusWire.getASegmentFromId model.Wire segId let snapXY, delta = snap2DSegment model.AutomaticScrolling mMsg.Pos aSegment model let newPos = aSegment.Start + delta - let newmMsg = {mMsg with Pos = newPos} - + let newmMsg = {mMsg with Pos = newPos} + { model with Action = nextAction; LastMousePos = mMsg.Pos; @@ -223,18 +236,18 @@ let snapWire SnapSegments = snapXY }, Cmd.batch [ wireCmd (BusWireT.DragSegment (segIdL, newmMsg)); - sheetCmd CheckAutomaticScrolling] + sheetCmd CheckAutomaticScrolling] let hextoInt (s:string) = let s0 = s[0].ToString() let s1 = s[1].ToString() - let i0 = + let i0 = match s0 with |"a" -> 10 |"b" ->11 |"c" ->12 |"d" ->13 |"e" ->14 |"f" ->15 |_ -> int <| s0 - let i1 = + let i1 = match s1 with |"a" -> 10 |"b" ->11 |"c" ->12 |"d" ->13 |"e" ->14 |"f" ->15 |_ -> int <| s1 @@ -248,16 +261,16 @@ let appendUndoList (undoList: Model List) (model_in: Model): Model List = |> List.truncate (max 0 (inputLst.Length - 1)) match List.length undoList with - | n when n < 500 -> + | n when n < 500 -> model_in :: undoList - | _ -> + | _ -> model_in :: (removeLast undoList) /// Mouse Down Update, Can have clicked on: Label, InputPort / OutputPort / Component / Wire / Canvas. Do correct action for each. -let mDownUpdate - (model: Model) - (mMsg: MouseT) +let mDownUpdate + (model: Model) + (mMsg: MouseT) : Model * Cmd = let newModel = match model.TmpModel with @@ -296,14 +309,14 @@ let mDownUpdate | Label compId -> {model with Action = InitialiseMovingLabel compId; TmpModel = Some model}, sheetCmd (SheetT.Msg.Wire (BusWireT.Msg.Symbol (SelectSymbols [compId]))) - + | InputPort (portId, portLoc) -> if not model.CtrlKeyDown then {model with Action = ConnectingInput portId; ConnectPortsLine = portLoc, mMsg.Pos; TmpModel=Some model}, symbolCmd SymbolT.ShowAllOutputPorts else let portIdstr = match portId with | InputPortId x -> x - {model with Action = MovingPort portIdstr}, + {model with Action = MovingPort portIdstr}, symbolCmd (SymbolT.MovePort (portIdstr, mMsg.Pos)) | OutputPort (portId, portLoc) -> @@ -321,13 +334,13 @@ let mDownUpdate else let symbolMap = Optic.get symbols_ model let symbol = symbolMap[compId] - {model with Action = ResizingSymbol (compId, fixedCornerLoc); LastValidSymbol = Some symbol}, + {model with Action = ResizingSymbol (compId, fixedCornerLoc); LastValidSymbol = Some symbol}, symbolCmd (SymbolT.ResizeSymbol (compId, fixedCornerLoc, mMsg.Pos)) // HLP 23: AUTHOR Khoury & Ismagilov // Modified and added parts to deal with the scaling box functions | Component compId -> match model.Wire.Symbol.Symbols[compId].Annotation with - | Some ScaleButton -> + | Some ScaleButton -> let scalingBoxCentre:XYPos = model.ScalingBox.Value.ScalingBoxBound.Centre() // printfn "startCentre:%A" scalingBoxCentre // printfn "startMousePos:%A" mMsg.Pos @@ -337,13 +350,13 @@ let mDownUpdate Action = Scaling; LastMousePos = mMsg.Pos; TmpModel = Some model}, Cmd.none - + | Some (RotateButton rotation) -> - {model with TmpModel = Some model; Action = Idle}, - Cmd.batch [ sheetCmd (Rotate rotation); + {model with TmpModel = Some model; Action = Idle}, + Cmd.batch [ sheetCmd (Rotate rotation); wireCmd (BusWireT.UpdateConnectedWires model.SelectedComponents)] - |_ -> + |_ -> let msg, action = DoNothing, InitialiseMoving compId if model.CtrlKeyDown || mMsg.ShiftKeyDown then @@ -352,12 +365,12 @@ let mDownUpdate then List.filter (fun cId -> cId <> compId) model.SelectedComponents // If component selected was already in the list, remove it else compId :: model.SelectedComponents // If user clicked on a new component add it to the selected list - {model with SelectedComponents = newComponents; + {model with SelectedComponents = newComponents; SnapSymbols = emptySnap; - LastValidPos = mMsg.Pos; - LastValidBoundingBoxes=model.BoundingBoxes; - Action = action; LastMousePos = mMsg.Pos; - //TmpModel = Some model; + LastValidPos = mMsg.Pos; + LastValidBoundingBoxes=model.BoundingBoxes; + Action = action; LastMousePos = mMsg.Pos; + //TmpModel = Some model; PrevWireSelection = model.SelectedWires}, Cmd.batch [symbolCmd (SymbolT.SelectSymbols newComponents); sheetCmd msg] else @@ -367,20 +380,20 @@ let mDownUpdate else [compId], [] // If user clicked on a new component, select that one instead let snapXY = match newComponents with - | [compId] -> + | [compId] -> getNewSymbolSnapInfo model model.Wire.Symbol.Symbols[compId] | _ -> emptySnap - {model with - SelectedComponents = newComponents; + {model with + SelectedComponents = newComponents; SnapSymbols = snapXY; - LastValidPos = mMsg.Pos; - LastValidBoundingBoxes=model.BoundingBoxes; - SelectedWires = newWires; Action = action; + LastValidPos = mMsg.Pos; + LastValidBoundingBoxes=model.BoundingBoxes; + SelectedWires = newWires; Action = action; LastMousePos = mMsg.Pos}, // TmpModel = Some model}, Cmd.batch [ symbolCmd (SymbolT.SelectSymbols newComponents) wireCmd (BusWireT.SelectWires newWires) sheetCmd msg] - + | Connection connId -> let aSegL = BusWireUpdateHelpers.getClickedSegment model.Wire connId mMsg.Pos let segIdL = aSegL |> List.map (fun aSeg -> aSeg.Segment.GetId) @@ -395,24 +408,24 @@ let mDownUpdate else connId :: model.SelectedWires // If user clicked on a new component add it to the selected list match model.ErrorComponents with - | [] -> + | [] -> { model with SelectedWires = newWires; Action = Idle; TmpModel = Some model; PrevWireSelection = model.SelectedWires}, Cmd.batch [wireCmd (BusWireT.SelectWires newWires); sheetCmd msg] - | _ -> + | _ -> printfn "Error components (Right)" - {model with Action = DragAndDrop}, + {model with Action = DragAndDrop}, Cmd.batch [sheetCmd DoNothing] else let snapXY = getNewSegmentSnapInfo model aSegL - {model with - SelectedComponents = []; - SelectedWires = [ connId ]; + {model with + SelectedComponents = []; + SelectedWires = [ connId ]; SnapSegments = snapXY - Action = MovingWire segIdL; + Action = MovingWire segIdL; TmpModel = Some model}, Cmd.batch [ symbolCmd (SymbolT.SelectSymbols []) wireCmd (BusWireT.SelectWires [ connId ]) @@ -425,18 +438,18 @@ let mDownUpdate then model.SelectedComponents, model.SelectedWires //do not deselect if in CtrlKeyDown mode else [], [] // Start Creating Selection Box and Reset Selected Components - let initialiseSelection = + let initialiseSelection = {model.DragToSelectBox with TopLeft= {X=mMsg.Pos.X; Y=mMsg.Pos.Y}} match model.CtrlKeyDown with | true -> match model.ErrorComponents with - | [] -> + | [] -> {model with DragToSelectBox = initialiseSelection; Action = Selecting; SelectedComponents = newComponents; SelectedWires = newWires }, Cmd.batch [ symbolCmd (SymbolT.SelectSymbols newComponents) wireCmd (BusWireT.SelectWires newWires) ] - | _ -> + | _ -> printfn "Error components (Right)" - {model with Action = DragAndDrop}, + {model with Action = DragAndDrop}, Cmd.none | false -> @@ -447,50 +460,50 @@ let mDownUpdate wireCmd (BusWireT.SelectWires newWires) ] | _ -> match model.ErrorComponents with - | [] -> + | [] -> //printfn "No error components (Wrong)" {model with DragToSelectBox = initialiseSelection; Action = Selecting; SelectedComponents = newComponents; SelectedWires = newWires}, Cmd.batch [ symbolCmd (SymbolT.SelectSymbols newComponents) wireCmd (BusWireT.SelectWires newWires)] - | _ -> + | _ -> //printfn "Error components (Right)" - {model with Action = DragAndDrop}, + {model with Action = DragAndDrop}, Cmd.batch [sheetCmd DoNothing] /// Mouse Drag Update, can be: drag-to-selecting, moving symbols, connecting wire between ports. -let mDragUpdate - (model: Model) - (mMsg: MouseT) +let mDragUpdate + (model: Model) + (mMsg: MouseT) : Model * Cmd = let setDragCursor (model:Model, cmd: Cmd) : Model*Cmd = - let dragCursor = + let dragCursor = match model.Action with | MovingLabel -> Grabbing | MovingSymbols -> ClickablePort | _ -> model.CursorType {model with CursorType = dragCursor}, cmd match model.Action with - | MovingWire segIdL -> + | MovingWire segIdL -> snapWire model mMsg segIdL // HLP 23: AUTHOR Khoury & Ismagilov // New Action, when we click on scaling button and drag the components and box should scale with mouse | Scaling -> let modelBeforeUpdate = model let scalingBoxCentre:XYPos = model.ScalingBoxCentrePos - let newScalingBoxOppositeMouse = + let newScalingBoxOppositeMouse = {X = scalingBoxCentre.X - (mMsg.Pos.X - scalingBoxCentre.X); Y = scalingBoxCentre.Y - (mMsg.Pos.Y - scalingBoxCentre.Y)} - + // printfn " mousePos:%A" mMsg.Pos // printfn " newScalingBoxOppositeMouse:%A" newScalingBoxOppositeMouse - let newBBMin = + let newBBMin = {X = min (newScalingBoxOppositeMouse.X) (mMsg.Pos.X) + 50.; Y = min (newScalingBoxOppositeMouse.Y) (mMsg.Pos.Y) + 50.} - let newBBMax = + let newBBMax = {X = max (newScalingBoxOppositeMouse.X) (mMsg.Pos.X) - 50.; Y = max (newScalingBoxOppositeMouse.Y) (mMsg.Pos.Y) - 50.} - + let selectedSymbols = RotateScale.findSelectedSymbols (modelBeforeUpdate.SelectedComponents) (modelBeforeUpdate.Wire.Symbol) let xYSC = RotateScale.getScalingFactorAndOffsetCentreGroup newBBMin newBBMax selectedSymbols @@ -509,24 +522,24 @@ let mDragUpdate modelBeforeUpdate.SelectedComponents |> List.filter (fun sId -> not (notIntersectingSelectedComponents newModel newModel.BoundingBoxes[sId] sId)) - let staySameModel = + let staySameModel = if errorSelectedComponents<>[] then (Some modelBeforeUpdate) elif (oneCompBoundsBothEdges && model.ScalingTmpModel.IsSome) then (modelBeforeUpdate.ScalingTmpModel) else None - - let scalingTmpModel = - match oneCompBoundsBothEdges, modelBeforeUpdate.ScalingTmpModel.IsNone, errorSelectedComponents<>[] with + + let scalingTmpModel = + match oneCompBoundsBothEdges, modelBeforeUpdate.ScalingTmpModel.IsNone, errorSelectedComponents<>[] with | true, true, _ -> None | false, _, false -> Some newModel | _ -> modelBeforeUpdate.ScalingTmpModel - + if (staySameModel.IsSome) then //printfn "scaling stay same" {staySameModel.Value with ScrollingLastMousePos = {Pos=mMsg.Pos;Move=mMsg.ScreenMovement} ScalingTmpModel = scalingTmpModel; - }, + }, Cmd.batch [ sheetCmd CheckAutomaticScrolling wireCmd (BusWireT.UpdateConnectedWires staySameModel.Value.SelectedComponents) @@ -538,7 +551,7 @@ let mDragUpdate ScalingTmpModel = scalingTmpModel ScrollingLastMousePos = {Pos=mMsg.Pos;Move=mMsg.ScreenMovement} ErrorComponents = errorComponents}, - Cmd.batch [ + Cmd.batch [ symbolCmd (SymbolT.ErrorSymbols (errorComponents,newModel.SelectedComponents,false)) sheetCmd CheckAutomaticScrolling wireCmd (BusWireT.UpdateConnectedWires model.SelectedComponents) @@ -571,7 +584,7 @@ let mDragUpdate let movingCompId = match model.SelectedLabel with | Some compid -> compid - | None -> + | None -> failwithf "What? no component found for moving label operation" {model with Action = MovingLabel @@ -582,7 +595,7 @@ let mDragUpdate symbolCmd (SymbolT.MoveLabel (movingCompId, mMsg.Pos - model.LastMousePos)) | ConnectingInput _ -> - let nearbyComponents = findNearbyComponents model mMsg.Pos 50 + let nearbyComponents = findNearbyComponents model mMsg.Pos 50 let _, nearbyOutputPorts = findNearbyPorts model let targetPort, drawLineTarget = @@ -627,12 +640,12 @@ let mDragUpdate sheetCmd (UpdateSingleBoundingBox compId) symbolCmd (ErrorSymbols (errorComponents,[compId],false)) wireCmd (BusWireT.UpdateSymbolWires compId);] - + | Panning initPos-> let sPos = initPos - mMsg.ScreenPage model, sheetCmd (Msg.UpdateScrollPos sPos) - | Idle - | InitialisedCreateComponent _ + | Idle + | InitialisedCreateComponent _ | Scrolling -> model, Cmd.none |> setDragCursor @@ -648,13 +661,13 @@ let mUpUpdate (model: Model) (mMsg: MouseT) : Model * Cmd = // mM | MovingWire segIdL -> let connIdL = segIdL |> List.map snd let coalesceCmds = connIdL |> List.map (fun conn -> wireCmd (BusWireT.CoalesceWire conn)) - { model with Action = Idle; UndoList = appendUndoList model.UndoList newModel}, - Cmd.batch ([ wireCmd (BusWireT.DragSegment (segIdL, mMsg)) + { model with Action = Idle; UndoList = appendUndoList model.UndoList newModel}, + Cmd.batch ([ wireCmd (BusWireT.DragSegment (segIdL, mMsg)) wireCmd (BusWireT.MakeJumps (true,connIdL )) ] @ coalesceCmds) | Selecting -> //let box = model.DragToSelectBox let newComponents = findIntersectingComponents model model.DragToSelectBox - let newWires = + let newWires = BusWireUpdate.getIntersectingWires model.Wire model.DragToSelectBox |> List.map fst let resetDragToSelectBox = {model.DragToSelectBox with H = 0.0; W = 0.0} @@ -663,19 +676,19 @@ let mUpUpdate (model: Model) (mMsg: MouseT) : Model * Cmd = // mM model.SelectedComponents, model.SelectedWires elif model.CtrlKeyDown then symDiff newComponents model.SelectedComponents, symDiff newWires model.SelectedWires - else + else newComponents, newWires // HLP 23: AUTHOR Khoury & Ismagilov - { model with - DragToSelectBox = resetDragToSelectBox; - Action = Idle; SelectedComponents = selectComps; - SelectedWires = selectWires; + { model with + DragToSelectBox = resetDragToSelectBox; + Action = Idle; SelectedComponents = selectComps; + SelectedWires = selectWires; AutomaticScrolling = false }, Cmd.batch [ symbolCmd (SymbolT.SelectSymbols selectComps) sheetCmd DoNothing wireCmd (BusWireT.SelectWires selectWires)] - | InitialiseMoving compId -> + | InitialiseMoving compId -> // not sure there is any point to running this from mouse UP this now we are not altering selection? // legacy case due for removal? { model with Action = Idle}, wireCmd (BusWireT.SelectWires []) @@ -687,11 +700,11 @@ let mUpUpdate (model: Model) (mMsg: MouseT) : Model * Cmd = // mM | MovingLabel -> {model with Action = Idle; UndoList = appendUndoList model.UndoList newModel}, sheetCmd DoNothing - | Scaling -> - let outputModel = + | Scaling -> + let outputModel = match model.ErrorComponents with |[] -> model - | _ -> newModel + | _ -> newModel {outputModel with Action = Idle; UndoList = appendUndoList model.UndoList newModel}, sheetCmd DoNothing | MovingSymbols -> @@ -700,7 +713,7 @@ let mUpUpdate (model: Model) (mMsg: MouseT) : Model * Cmd = // mM | [] -> let movingWires = BusWireUpdateHelpers.getConnectedWireIds model.Wire model.SelectedComponents match model.SelectedComponents.Length with - | s when s < 2 -> + | s when s < 2 -> {model with BoundingBoxes = model.LastValidBoundingBoxes Action = Idle @@ -709,7 +722,7 @@ let mUpUpdate (model: Model) (mMsg: MouseT) : Model * Cmd = // mM SnapSegments = emptySnap AutomaticScrolling = false }, wireCmd (BusWireT.MakeJumps (true,movingWires)) - | _ -> + | _ -> {model with ErrorComponents = []; BoundingBoxes = model.LastValidBoundingBoxes; @@ -723,7 +736,7 @@ let mUpUpdate (model: Model) (mMsg: MouseT) : Model * Cmd = // mM //wireCmd (BusWireT.UpdateWires (model.SelectedComponents, model.LastValidPos - mMsg.Pos)) wireCmd (BusWireT.MakeJumps (true,movingWires)) sheetCmd DoNothing] - + | _ -> let movingWires = BusWireUpdateHelpers.getConnectedWireIds model.Wire model.SelectedComponents @@ -764,8 +777,8 @@ let mUpUpdate (model: Model) (mMsg: MouseT) : Model * Cmd = // mM wireCmd (BusWireT.RerouteWire portId)] // HLP23 AUTHOR: BRYAN TAN - | ResizingSymbol (compId, fixedCornerLoc) -> - match model.ErrorComponents with + | ResizingSymbol (compId, fixedCornerLoc) -> + match model.ErrorComponents with | [] -> {model with Action = Idle; LastValidSymbol = None; UndoList = appendUndoList model.UndoList newModel}, Cmd.batch [ @@ -778,10 +791,10 @@ let mUpUpdate (model: Model) (mMsg: MouseT) : Model * Cmd = // mM Action = Idle SnapSymbols = emptySnap SnapSegments = emptySnap - AutomaticScrolling = false + AutomaticScrolling = false LastValidSymbol = None }, - Cmd.batch [ + Cmd.batch [ symbolCmd (SymbolT.ResizeSymbolDone (compId, model.LastValidSymbol, fixedCornerLoc, mMsg.Pos)) sheetCmd UpdateBoundingBoxes symbolCmd (SymbolT.SelectSymbols (model.SelectedComponents)) @@ -790,16 +803,16 @@ let mUpUpdate (model: Model) (mMsg: MouseT) : Model * Cmd = // mM | _ -> model, Cmd.batch [sheetCmd DoNothing] /// Mouse Move Update, looks for nearby components and looks if mouse is on a port -let mMoveUpdate - (model: Model) - (mMsg: MouseT) +let mMoveUpdate + (model: Model) + (mMsg: MouseT) : Model * Cmd = match model.Action with | DragAndDrop -> moveSymbols model mMsg | InitialisedCreateComponent (ldcs, compType, lbl) -> - let labelTest = + let labelTest = match compType with |Input _ | Input1 (_,_) |Output _ |Viewer _ |IOLabel -> SymbolUpdate.generateIOLabel model.Wire.Symbol compType lbl @@ -818,7 +831,7 @@ let mMoveUpdate symbolCmd (SymbolT.PasteSymbols [ newCompId ]) ] | _ -> let nearbyComponents = findNearbyComponents model mMsg.Pos 50 // TODO Group Stage: Make this more efficient, update less often etc, make a counter? - + // HLP23 AUTHOR: BRYAN TAN let ctrlPressed = List.exists (fun (k,_) -> k = "CONTROL") (SheetDisplay.getActivePressedKeys model) let newCursor = @@ -830,20 +843,20 @@ let mMoveUpdate // | InputPort _ | OutputPort _ -> ClickablePort // Change cursor if on port | Label _ -> GrabLabel | Connection _ -> GrabWire - | Component compId -> - match model.Wire.Symbol.Symbols[compId].Annotation with + | Component compId -> + match model.Wire.Symbol.Symbols[compId].Annotation with | Some ScaleButton -> ResizeNESW | _ -> GrabSymbol - | ComponentCorner (_,_,idx) when ctrlPressed -> + | ComponentCorner (_,_,idx) when ctrlPressed -> match (idx % 2) with | 0 -> ResizeNWSE | _ -> ResizeNESW | _ -> Default - let newModel = { model with NearbyComponents = nearbyComponents; CursorType = newCursor; LastMousePos = mMsg.Pos; ScrollingLastMousePos = {Pos=mMsg.Pos;Move=mMsg.ScreenMovement} } - + let newModel = { model with NearbyComponents = nearbyComponents; CursorType = newCursor; LastMousePos = mMsg.Pos; ScrollingLastMousePos = {Pos=mMsg.Pos;Move=mMsg.ScreenMovement} } + if ctrlPressed then newModel , Cmd.batch [symbolCmd (SymbolT.ShowCustomOnlyPorts nearbyComponents); symbolCmd (SymbolT.ShowCustomCorners nearbyComponents)] - else + else newModel, symbolCmd (SymbolT.ShowPorts nearbyComponents) // Show Ports of nearbyComponents let getVisibleScreenCentre (model : Model) : XYPos = @@ -855,18 +868,18 @@ let getVisibleScreenCentre (model : Model) : XYPos = let validateTwoSelectedSymbols (model:Model) = match model.SelectedComponents with - | [s1; s2] as syms -> + | [s1; s2] as syms -> let symbols = model.Wire.Symbol.Symbols - let getSym sId = + let getSym sId = Map.tryFind sId symbols match getSym s1, getSym s2 with - | Some s1, Some s2 -> + | Some s1, Some s2 -> printfn $"Testing with\ns1= {s1.Component.Type}\n s2={s2.Component.Type}" Some(s1,s2) - | _ -> + | _ -> printfn "Error: can't validate the two symbols selected to reorder ports" None - | syms -> + | syms -> printfn $"Can't test because number of selected symbols ({syms.Length}) is not 2" None @@ -886,7 +899,7 @@ let rec getChannel (bb1:BoundingBox) (bb2:BoundingBox) : (BoundingBox * Orientat None // symbols are not aligned vertically // Vertical Channel elif bb2.TopLeft.X > bb1.TopLeft.X + bb1.W then - let x1, x2 = bb1.TopLeft.X + bb1.W, bb2.TopLeft.X + let x1, x2 = bb1.TopLeft.X + bb1.W, bb2.TopLeft.X let union = boxUnion bb1 bb2 let topLeft = { Y=union.TopLeft.Y; X=x1 } Some ( { TopLeft = topLeft; H = union.H; W = x2 - x1 }, Vertical ) diff --git a/src/Renderer/DrawBlock/SymbolPortHelpers.fs b/src/Renderer/DrawBlock/SymbolPortHelpers.fs index f5dce873c..f97db7eea 100644 --- a/src/Renderer/DrawBlock/SymbolPortHelpers.fs +++ b/src/Renderer/DrawBlock/SymbolPortHelpers.fs @@ -4,6 +4,7 @@ open Elmish open Fable.React.Props open CommonTypes open Fable.React +open DrawModelType open DrawModelType.SymbolT open Symbol open Optics @@ -15,7 +16,7 @@ open Operators let findDeletedPorts (symModel: Model) (compId: ComponentId) (oldComp:Component) (newComp: ComponentType) = let symbol = Map.find compId symModel.Symbols let oldCompType = oldComp.Type - let removedIds = + let removedIds = match oldCompType,newComp with |NbitsAdder _,NbitsAdderNoCin _ |NbitsAdderNoCout _,NbitsAdderNoCinCout _-> [symbol.Component.InputPorts[0].Id] @@ -35,32 +36,32 @@ let findDeletedPorts (symModel: Model) (compId: ComponentId) (oldComp:Component) symbol.Component.OutputPorts[numInNew..] |> List.map (fun x -> x.Id) | _ -> [] - + removedIds |> List.map (fun x -> Map.tryFind x symModel.Ports) -////////////// Show Ports Helpers ///////////////////// +//------------ Optics for Show Port Helpers--------------// -let showSymbolInPorts _ sym = +let showSymbolInPorts _ sym = set (appearance_ >-> showPorts_) ShowInput sym -let showSymbolOutPorts _ sym = - set (appearance_ >-> showPorts_) ShowOutput sym +let showSymbolOutPorts _ sym = + set (appearance_ >-> showPorts_) ShowOutput sym let showSymbolBothForPortMovementPorts _ sym = - set (appearance_ >-> showPorts_) ShowBothForPortMovement sym + set (appearance_ >-> showPorts_) ShowBothForPortMovement sym -let hideSymbolPorts _ sym = +let hideSymbolPorts _ sym = set (appearance_ >-> showPorts_) ShowNone sym let showSymbolPorts sym = - set (appearance_ >-> showPorts_) ShowBoth sym + set (appearance_ >-> showPorts_) ShowBoth sym -///////////////////////////////////////////////////////// +//------------ Show Port Helpers--------------// /// Given a model it shows all input ports and hides all output ports, then returns the updated model let inline showAllInputPorts (model: Model) = - let newSymbols = + let newSymbols = model.Symbols |> Map.map showSymbolInPorts @@ -68,7 +69,7 @@ let inline showAllInputPorts (model: Model) = /// Given a model it shows all output ports and hides all input ports, then returns the updated model let inline showAllOutputPorts (model: Model) = - let newSymbols = + let newSymbols = model.Symbols |> Map.map showSymbolOutPorts @@ -76,7 +77,7 @@ let inline showAllOutputPorts (model: Model) = /// Given a model it shows all ports of custom components and hides all other ports, then returns the updated model let inline showAllCustomPorts (model: Model) = - let newSymbols = + let newSymbols = model.Symbols |> Map.map showSymbolBothForPortMovementPorts @@ -84,7 +85,7 @@ let inline showAllCustomPorts (model: Model) = /// Given a model it hides all ports and returns the updated model let inline deleteAllPorts (model: Model) = - let updatedSymbols = + let updatedSymbols = model.Symbols |> Map.map hideSymbolPorts @@ -92,7 +93,7 @@ let inline deleteAllPorts (model: Model) = /// Given a model it shows all the specified components' ports and hides all the other ones let inline showPorts (model: Model) compList = - let resetSymbols = + let resetSymbols = model.Symbols |> Map.map hideSymbolPorts @@ -118,7 +119,7 @@ let inline showPorts (model: Model) compList = /// Given a model it shows only the custom components of all the specified components' ports and hides all the other ones /// Different from the above (only custom components). let inline showCustomPorts (model: Model) compList = - let resetSymbols = + let resetSymbols = model.Symbols |> Map.map hideSymbolPorts @@ -132,7 +133,7 @@ let inline showCustomPorts (model: Model) compList = { model with Symbols = newSymbols} - +/// Helper popup that shows when a custom component is selected, and (Edit menu > Move Component Ports) is clicked. let moveCustomPortsPopup() : ReactElement = let styledSpan styles txt = span [Style styles] [str <| txt] let bSpan txt = styledSpan [FontWeight "bold"] txt @@ -147,30 +148,30 @@ let moveCustomPortsPopup() : ReactElement = however port positions cannot be changed."] li [] [ str "2-input MUX components can have 0 & 1 inputs swapped using properties."] - + li [] [str "Custom components (sheets inserted as components) can have ports moved \ to any side of the symbol and reordered."] - - li [] [ + + li [] [ str "To move custom component ports:" ul [Style [ListStyle "circle"; MarginLeft "30px"]] - [ + [ li [] [str "Press CTRL and use a mouse to drag \ - a port to another position on the outline of the symbol."] - li [] [str "You can reorder ports and place them on any symbol edge including top and bottom." ] + a port to another position on the outline of the symbol."] + li [] [str "You can reorder ports and place them on any symbol edge including top and bottom." ] li [] [str "The symbol will resize itself if you change the edge of a port."] li [] [str "If default sizing makes port legends overlap you can scale the custom component dragging its corners"] ] ] ] ] - - + + /// Returns an Option Edge. Returns Some edge if position is on edge of Symbol, and None if it was not on an edge /// Separates the symbol as shown below where the two triangles have height = 0.3*symbolHeight // |-----------| // |\ TOP /| -// | \ / | +// | \ / | // | \ / | // |LEFT | | // | |RIGHT| @@ -181,11 +182,11 @@ let moveCustomPortsPopup() : ReactElement = let getCloseByEdge (sym:Symbol) (mousePos:XYPos) : Option = let h,w = getRotatedHAndW sym let triangleCorner = {X=w/2.;Y=h*0.3} - let tanTheta = triangleCorner.Y/triangleCorner.X + let tanTheta = triangleCorner.Y/triangleCorner.X let mouseOffset = mousePos - sym.Pos let minX = min (abs mouseOffset.X) (abs w-mouseOffset.X) let outMargin = 60. //how many pixels outside the symbol the port can be when moving it - + // Top Edge if ((-outMargin <= mouseOffset.Y) && (mouseOffset.Y <= (minX*tanTheta)) && ((-outMargin <= mouseOffset.X)) && ((w+outMargin) >= mouseOffset.X)) then Some Top // Bottom Edge @@ -202,50 +203,51 @@ let getCloseByEdge (sym:Symbol) (mousePos:XYPos) : Option = let getPosIndex (sym: Symbol) (pos: XYPos) (edge: Edge): int = let ports = sym.PortMaps.Order[edge] //list of ports on the same side as port //let index = float( List.findIndex (fun (p:string) -> p = port.Id) ports ) need to find index - let gap = getPortPosEdgeGap sym.Component.Type + let gap = getPortPosEdgeGap sym.Component.Type let baseOffset = getPortBaseOffset sym edge //offset of the side component is on - let pos' = pos - sym.Pos + baseOffset + let pos' = pos - sym.Pos + baseOffset let h,w = getRotatedHAndW sym match ports.Length, edge with - | 0, _ -> 0 + | 0, _ -> 0 | _, Left -> int (pos'.Y * ( float( ports.Length + 1) + 2.0*gap - 1.0) / float(h) - gap + 0.5) - | _, Right -> + | _, Right -> -1 * int (pos'.Y * ( float( ports.Length + 1 ) + 2.0*gap - 1.0) / float(h) + 1.0 - gap - float( ports.Length + 1) - 0.5) - | _, Bottom -> + | _, Bottom -> int (pos'.X * (float (ports.Length + 1) + 2.0*gap - 1.0) / (float(w)) - gap + 0.5) | _, Top -> -1 * int (pos'.X * (float (ports.Length + 1) + 2.0*gap - 1.0) / float(w) - float( ports.Length + 1) + 1.0 - gap - 0.5) +/// Given a symbol, a position and a portId, it returns the updated symbol with the port moved to the new position let updatePortPos (sym:Symbol) (pos:XYPos) (portId: string) : Symbol = match sym.Component.Type with | Custom x -> let oldMaps = sym.PortMaps match getCloseByEdge sym pos with - | None -> + | None -> printfn "not on edge" {sym with MovingPort = None} - | Some edge -> + | Some edge -> printfn $"{edge}" let newPortOrientation = oldMaps.Orientation |> Map.add portId edge let oldEdge = oldMaps.Orientation[portId] let newPortIdx = getPosIndex sym pos edge let oldIdx = oldMaps.Order[oldEdge] |> List.findIndex (fun el -> el = portId) - + let oldPortOrder' = - oldMaps.Order + oldMaps.Order |> Map.add oldEdge (oldMaps.Order[oldEdge] |> List.filter (fun el -> el <> portId)) let newPortIdx' = if newPortIdx > oldPortOrder'[edge].Length then oldPortOrder'[edge].Length else if edge = oldEdge && oldIdx < newPortIdx then newPortIdx - 1 else newPortIdx printfn $"{(newPortIdx, newPortIdx')}" - - let newPortOrder = + + let newPortOrder = oldPortOrder' |> Map.add edge (oldPortOrder'[edge] |> List.insertAt newPortIdx' portId) // to do then get index and insert at index let newSym = - {sym with + {sym with MovingPort = None; PortMaps = {Orientation = newPortOrientation; Order = newPortOrder} } @@ -255,11 +257,11 @@ let updatePortPos (sym:Symbol) (pos:XYPos) (portId: string) : Symbol = /// Contains the code for the MovePort update msg let movePortUpdate (model:Model) (portId:string) (pos:XYPos) : Model*Cmd<'a> = - - /// Get a port's position given the symbol, the side the port is on, the number of ports on that side and the index of the port on that side + + /// Get a port's position given the symbol, the side the port is on, the number of ports on that side and the index of the port on that side let getPortPosWithIndex (sym: Symbol) portsNumber side portIndex: XYPos = let index = float(portIndex) - let gap = getPortPosEdgeGap sym.Component.Type + let gap = getPortPosEdgeGap sym.Component.Type let topBottomGap = gap + 0.3 // extra space for clk symbol let baseOffset = getPortBaseOffset sym side //offset of the side component is on let baseOffset' = baseOffset + getMuxSelOffset sym side @@ -269,17 +271,17 @@ let movePortUpdate (model:Model) (portId:string) (pos:XYPos) : Model*Cmd<'a> = | Left -> let yOffset = float h * ( index + gap )/(portDimension + 2.0*gap) baseOffset' + {X = 0.0; Y = yOffset } - | Right -> + | Right -> let yOffset = float h * (portDimension - index + gap )/(portDimension + 2.0*gap) baseOffset' + {X = 0.0; Y = yOffset } - | Bottom -> + | Bottom -> let xOffset = float w * (index + topBottomGap)/(portDimension + 2.0*topBottomGap) baseOffset' + {X = xOffset; Y = 0.0 } | Top -> let xOffset = float w * (portDimension - index + topBottomGap)/(portDimension + 2.0*topBottomGap) baseOffset' + {X = xOffset; Y = 0.0 } - - /// Helper function to get the X or Y offset of the Moving Port target, when the target is on the same side the port was before + + /// Helper function to get the X or Y offset of the Moving Port target, when the target is on the same side the port was before let findOffsetSameEdge (symbol:Symbol) edge = let portsOnEdge = List.length symbol.PortMaps.Order[edge] if portsOnEdge = 1 then 0.0 @@ -292,22 +294,22 @@ let movePortUpdate (model:Model) (portId:string) (pos:XYPos) : Model*Cmd<'a> = elif portsOnEdge > 2 then match edge with |Bottom |Top -> ((getPortPosWithIndex symbol portsOnEdge edge 1).X - (getPortPosWithIndex symbol portsOnEdge edge 0).X)/2.0 - | _ -> ((getPortPosWithIndex symbol portsOnEdge edge 1).Y - (getPortPosWithIndex symbol portsOnEdge edge 0).Y)/2.0 + | _ -> ((getPortPosWithIndex symbol portsOnEdge edge 1).Y - (getPortPosWithIndex symbol portsOnEdge edge 0).Y)/2.0 else 0.0 - /// Helper function to get the X or Y offset of the Moving Port target, when the target is NOT on the same side the port was before + /// Helper function to get the X or Y offset of the Moving Port target, when the target is NOT on the same side the port was before let findOffsetDifferentEdge (symbol:Symbol) edge order= let portsOnEdge = List.length symbol.PortMaps.Order[edge] - if portsOnEdge = 0 then + if portsOnEdge = 0 then match edge with | Top | Bottom -> ((snd (getRotatedHAndW symbol))/2.0 ) | _ -> ((fst (getRotatedHAndW symbol))/2.0 ) - + elif (portsOnEdge>=1 && ((order=0) || (order=portsOnEdge)) ) then let (h,w) = (getRotatedHAndW symbol) let firstPortPos = getPortPosWithIndex symbol portsOnEdge edge 0 let lastPortPos = getPortPosWithIndex symbol portsOnEdge edge (portsOnEdge-1) - let firstPortXorY = match edge with |Top |Bottom -> firstPortPos.X | _ -> firstPortPos.Y + let firstPortXorY = match edge with |Top |Bottom -> firstPortPos.X | _ -> firstPortPos.Y let lastPortXorY = match edge with | Top | Bottom -> lastPortPos.X | _ -> lastPortPos.Y let hORw = match edge with | Top | Bottom -> w |_ -> h match (order,edge) with @@ -315,30 +317,30 @@ let movePortUpdate (model:Model) (portId:string) (pos:XYPos) : Model*Cmd<'a> = |(0,_) -> (hORw + firstPortXorY)/2.0 + 2.5 |(_,Bottom) | (_,Left) -> (hORw+lastPortXorY)/2.0 + 2.5 |(_,_) -> lastPortXorY/2.0 - 2.5 - - else + + else match edge with | Top | Bottom -> ((getPortPosWithIndex symbol portsOnEdge edge (order-1)).X + (getPortPosWithIndex symbol portsOnEdge edge order).X)/2.0 | _ -> ((getPortPosWithIndex symbol portsOnEdge edge (order-1)).Y + (getPortPosWithIndex symbol portsOnEdge edge order).Y)/2.0 /// Find the position of the target Port given the old/new edge and old/new order - let findTargetPos (port:Port) (symbol:Symbol) = + let findTargetPos (port:Port) (symbol:Symbol) = let tempSymbol = updatePortPos symbol pos port.Id let oldEdge = symbol.PortMaps.Orientation[port.Id] let oldOrder = List.findIndex (fun elem -> elem = port.Id) symbol.PortMaps.Order[oldEdge] let newEdge = tempSymbol.PortMaps.Orientation[port.Id] let newOrder = List.findIndex (fun elem -> elem = port.Id) tempSymbol.PortMaps.Order[newEdge] let newPortPos = Symbol.getPortPos tempSymbol port - - let x = + + let x = match newEdge with | Right -> snd (getRotatedHAndW symbol) | _ -> newPortPos.X - let y = + let y = match newEdge with | Bottom -> fst (getRotatedHAndW symbol) | _ -> newPortPos.Y - + if newEdge = oldEdge then let diff = findOffsetSameEdge symbol newEdge if (newEdge = Top) || (newEdge = Bottom) then @@ -348,36 +350,52 @@ let movePortUpdate (model:Model) (portId:string) (pos:XYPos) : Model*Cmd<'a> = else if oldOrder < newOrder then ({X=x;Y=y+diff},pos) elif oldOrder = newOrder then ({X=x;Y=y},pos) - else ({X=x;Y=y-diff},pos) - else + else ({X=x;Y=y-diff},pos) + else let offset = findOffsetDifferentEdge symbol newEdge newOrder if (newEdge = Top) || (newEdge = Bottom) then ({X=offset;Y=y},pos) else ({X=x;Y=offset},pos) - + /// return the correctly parameterised symbol given the edge the moving port is (or isn't) on - let isTouchingEdge port symId oldSymbol = + let isTouchingEdge port symId oldSymbol = match getCloseByEdge oldSymbol pos with - | None -> - let newSymbol = + | None -> + let newSymbol = oldSymbol |> set movingPort_ (Some {|PortId = portId; CurrPos = pos|}) |> set movingPortTarget_ None |> set (appearance_ >-> showPorts_) (ShowOneNotTouching port) - - set (symbolOf_ symId) newSymbol model, Cmd.none - | Some _ -> - let target = Some (findTargetPos port oldSymbol) - let newSymbol = + + set (symbolOf_ symId) newSymbol model, Cmd.none + | Some _ -> + let target = Some (findTargetPos port oldSymbol) + let newSymbol = oldSymbol - |> set movingPort_ (Some {|PortId = portId; CurrPos = pos|}) + |> set movingPort_ (Some {|PortId = portId; CurrPos = pos|}) |> set movingPortTarget_ target - |> set (appearance_ >-> showPorts_) (ShowOneTouching port) - + |> set (appearance_ >-> showPorts_) (ShowOneTouching port) + set (symbolOf_ symId) newSymbol model, Cmd.none - + let port = model.Ports[portId] let symId = ComponentId port.HostId let oldSymbol = model.Symbols[symId] match oldSymbol.Component.Type with | Custom _ -> isTouchingEdge port symId oldSymbol - | _ -> model, Cmd.none + | _ -> model, Cmd.none + + +/// +/// Helper that returns the Symbol corresponding to a given PortId. Needs to be given a SheetT.Model to search +/// If no symbol found, returns None +/// Author: tdc21/Tim +/// +let getSymbolFromPortID (portId: string) (model: DrawModelType.SheetT.Model) = + // PortId type is either an InputPortId or an OutputPortId + let portIdString = portId.ToString() + model.Wire.Symbol.Symbols + |> Map.values + |> Seq.toList + |> List.tryFind (fun symbol -> + symbol.PortMaps.Orientation.Keys + |> Seq.exists (fun key -> key = portIdString)) 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..01b5429ab 100644 --- a/src/Renderer/Renderer.fsproj +++ b/src/Renderer/Renderer.fsproj @@ -63,27 +63,28 @@ - + - - + + - + - - - - + + + + - + + @@ -103,6 +104,8 @@ + + diff --git a/src/Renderer/UI/DeveloperModeHelpers.fs b/src/Renderer/UI/DeveloperModeHelpers.fs new file mode 100644 index 000000000..ac95b8482 --- /dev/null +++ b/src/Renderer/UI/DeveloperModeHelpers.fs @@ -0,0 +1,323 @@ +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 // +// --------------------------------------------------- // + + +// -------- 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 (intersect2DBoxInfo 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 + + + + + diff --git a/src/Renderer/UI/DeveloperModeView.fs b/src/Renderer/UI/DeveloperModeView.fs new file mode 100644 index 000000000..4b75e8c6c --- /dev/null +++ b/src/Renderer/UI/DeveloperModeView.fs @@ -0,0 +1,515 @@ +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 +open BusWire +open IntersectionHelpers + + +(* +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 +*) + +let test1DSegIntersect (model:ModelType.Model) = + let wire1 = model.Sheet.Wire.Wires |> Map.values |> Array.head + let symbol1 = model.Sheet.Wire.Symbol.Symbols |> Map.values |> Array.head + + let wire1Abs = + getAbsSegments wire1 + |> List.map (fun aseg -> (aseg.Start, aseg.End)) + let bbox = getSymbolBoundingBox symbol1 + + wire1Abs + |> List.map (fun (s,e) -> segmentIntersectsBoundingBoxInfo bbox s e ) + |> List.choose id + + + + + +/// 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\nAssumption: \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() |} + {|DisplayName="CountAlmostStraight Wires"; + ToolTipDescription = "Counts the number of wires that are almost straight.\nWires that have a maximum deviation of 20px \nfrom the majority direction." + Value=(countAlmostStraightWiresOnSheet model.Sheet 20.0).ToString() |} + {|DisplayName="CountSinglyConnected Wires"; + ToolTipDescription = "Counts the number of singly-connected wires. A singly \nconnected wire is connected to at least one component \nthat has a single wire attached to it, .i.e a 'dead end'" + Value=(countSinglyConnectedWires model.Sheet).ToString() |}; + {|DisplayName="CheckWireIntersectSegs"; + ToolTipDescription = "asb"; Value=(test1DSegIntersect model).ToString() |} + ] + + // let testSegmentIntersectsBBox (model: ModelType.Model) : string = + // // check for at least two symbols, take the first and second, run with reSizeSymbolTopLevel + // match model.Sheet.Wire.Symbol.Symbols.Count >= 1 && model.Sheet.Wire.Wires.Count >= 1 with + // | true -> + // let firstWire = model.Sheet.Wire.Wires |> Map.values |> Array.head + + // model.Sheet.Wire.Symbol.Symbols + // |> Map.map (fun _ symbol -> + // let bbox = getSymbolBoundingBox symbol + // getAbsSegments firstWire + // |> List.skip 1 + // |> fun list -> List.take (List.length list - 2 ) list + // |> List.map (fun (aSeg: ASegment) -> + + // let segStart, segEnd = aSeg.Start, aSeg.End + // (aSeg.GetId, segmentIntersectsBoundingBox bbox segStart segEnd)) + // // get rid of Nones and convert to strings including ID + // |> List.choose (fun ((id, _), optIntersection) -> + // match optIntersection with + // | Some intersection -> Some (sprintf "id %A with intersect distance %f" (id.ToString()) intersection) + // | None -> None) + // |> String.concat "," + + // ) + // |> Map.toList + // |> List.map snd + // |> String.concat ", " + + + // | false -> "" + // let removeSingleWireInvisibleSegments (wire: Wire) = + // let uniqueVertices = + // segmentsToIssieVertices wire.Segments wire + // |> List.distinctBy (fun (x, y, _) -> (x, y)) + // let newSegments = issieVerticesToSegments wire.WId uniqueVertices + // // for each wire, set the segments to the new segments + // wire |> Optic.set segments_ newSegments + + // let testSegmentIntersectsBBox2 (model: ModelType.Model) : string = + // // check for at least two symbols, take the first and second, run with reSizeSymbolTopLevel + // match model.Sheet.Wire.Symbol.Symbols.Count >= 1 && model.Sheet.Wire.Wires.Count >= 1 with + // | true -> + // let firstWire = model.Sheet.Wire.Wires |> Map.values |> Array.head + // model.Sheet.Wire.Symbol.Symbols + // |> Map.map (fun _ symbol -> + // let bbox = getSymbolBoundingBox symbol + // getAbsSegments firstWire + // |> List.skip 1 + // |> fun list -> List.take (List.length list - 1 ) list + // |> List.map (fun (aSeg: ASegment) -> + + // let segStart, segEnd = aSeg.Start, aSeg.End + // (aSeg.GetId, getSegmentIntersectBBox bbox segStart segEnd)) + // // get rid of Nones and convert to strings including ID + // |> List.choose (fun (( id,_), optIntersection) -> + // match optIntersection with + // | Some intersection -> Some (sprintf "id %A with intersect area %A" (id.ToString()) (intersection.ToString())) + // | None -> None) + // |> String.concat ", " + + // ) + // |> Map.toList + // |> List.map snd + // |> String.concat ", " + + + // | false -> "" + + // let testOverlap1DIn2DInfo (model: ModelType.Model)= + // match model.Sheet.Wire.Symbol.Symbols.Count >= 2 && model.Sheet.Wire.Wires.Count >= 2 with + // | true -> + // let wires = + // model.Sheet.Wire.Wires + // |> Map.values + // |> Array.toList + // |> List.mapi (fun i wire -> (i, wire)) + + // List.allPairs wires wires + // |> List.filter (fun ((i1, wire1), (i2, wire2)) -> i1 > i2) + // |> List.map (fun ((i1, wire1), (i2, wire2)) -> + // let wire1Abs, wire2Abs = getAbsSegments wire1, getAbsSegments wire2 + // List.allPairs wire1Abs wire2Abs + // |> List.filter (fun (seg1: ASegment, seg2) -> seg1.Segment.Index <> seg2.Segment.Index) + // |> List.map (fun (seg1: ASegment, seg2) -> overlap1DIn2DInfo (seg1.Start, seg1.End) (seg2.Start, seg2.End)) + // |> List.choose id + // |> List.map (fun rect -> + // if rect.BottomRight = rect.TopLeft then + // rect.BottomRight.ToString() + // else + // sprintf "Overlap with TopLeft %A and BottomRight %A" rect.TopLeft rect.BottomRight + // ) + // |> String.concat ",") + // |> String.concat "; " + // | false -> "" + +// let countIntersectingSymbolPairs (model: SheetT.Model) = +// let boxes = +// mapValues model.BoundingBoxes +// |> Array.toList +// |> List.mapi (fun n box -> n, box) +// List.allPairs boxes boxes +// |> List.filter (fun ((n1, box1), (n2, box2)) -> (n1 <> n2) && BlockHelpers.overlap2DBox box1 box2) +// |> List.length +// // divide by 2 +// |> (fun x -> x / 2) + +// ----------------------------------------------------------------- // +// 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 + ]; + // div [Style [MarginBottom "20px"]] [ + // code [] [str (testOverlap1DIn2DInfo model)] + // ]; + + // div [Style [MarginBottom "20px"]] [ + // code [] [str (testSegmentIntersectsBBox model)] + // ]; + + // div [] [ + // code [] [str (testSegmentIntersectsBBox2 model)] + // ] + // div [] [ + // code [] [str (testSegmentIntersectsBBox2 model)] + // ] + ] + + + 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..53e566c2e 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,76 @@ 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