Diagram is the main module Contains method to convert ascii diagram into and svg
Converts the ascii text into an SVG diagram
Ascii -----> SVG
module Diagram exposing (toSvg)
{-|
Diagram is the main module
Contains method to convert ascii diagram into and svg
@docs toSvg
-}
import String
import Svg exposing (Svg,svg,path,line,marker,defs,pattern,rect)
import Svg.Attributes exposing (
x,y,x1,y1,x2,y2,height,
width,d,markerHeight,
markerWidth,orient,markerEnd,
markerUnits,refX,refY,viewBox,id,
stroke,strokeWidth,fill,strokeLinecap,
strokeLinejoin,strokeDasharray,
patternUnits
)
import Char
import Color
import Array exposing (Array)
fontSize = 14.0
lineWidth = 1.0
textWidth = 8.0
textHeight = 16.0
arcRadius = textWidth / 2
color = Color.rgb 0 0 0
optimizeSvg = False
density = Expanded
gridOn = False
type alias Model =
{rows: Int
,columns: Int
,lines: Array (Array Char)
}
{-| Converts the ascii text into an SVG diagram
Ascii -----> SVG
-}
toSvg: String -> Svg a
toSvg input =
init input
|> getSvg
init: String -> Model
init str =
let
lines = String.lines str
max =
List.map
(\line ->
String.length line
)lines
|> List.maximum
lineArr = Array.fromList lines
lineChar =
Array.map (
\line ->
(String.toList <| String.trimRight line)
|> Array.fromList
) lineArr
in
{rows = Array.length lineChar
,columns = Maybe.withDefault 0 max
,lines = lineChar
}
type Density = Compact | Medium | Expanded
measureX: Int -> Float
measureX x =
toFloat x * textWidth
measureY: Int -> Float
measureY y =
toFloat y * textHeight
type Location
= Top
| Bottom
| Left
| Right
| TopLeft
| TopRight
| BottomLeft
| BottomRight
-- plain simple elements
type Piece
{--
| :
| :
--}
= Vertical
{--
--- ===
--}
| Horizontal
{--
___ ....
--}
| LowHorizontal
{--
/
--}
| SlantRight
{--
\\
--}
| SlantLeft
type Action
= Extend
| Trim
type Outline
= Smooth -- . '
| Sharp -- + *
type Stroke
= Dashed -- : = ...
| Solid -- | - ___
type Component
= Text Char
| Piece Elevation Piece Stroke
| Arrow Location
| Corner Location Outline
| Action Elevation Piece Action Location Chunk
| Curve Location Elevation Chunk
| Junction Elevation (List Location) Outline -- + * . '
type Elevation
= Low
| Mid
| High
type Chunk
= Full
| Half
| Quarter
| Quarter3
type alias Point =
{ x : Float
, y: Float
}
type Path
= Line (Point, Point)
| ArrowLine (Point, Point)
| Arc (Point, Point, Float, Bool)
| DashedLine (Point, Point)
| TextPath (Point, String)
-- corresponding paths for each component
componentPathList: Int -> Int -> List (Component, List Path)
componentPathList x y =
let
-- block start/quarter/mid/quarter3/end x y
tw2 = textWidth / 2
tw4 = textWidth / 4
th2 = textHeight / 2
th4 = textHeight / 4
sx = measureX x
sy = measureY y
qx = measureX x + textWidth / 4
qy = measureY y + textHeight / 4
mx = measureX x + textWidth / 2
my = measureY y + textHeight / 2
q3x = measureX x + textWidth * 3 / 4
q3y = measureY y + textHeight * 3 /4
ex = measureX x + textWidth
ey = measureY y + textHeight
verticalPath = Line (Point mx sy, Point mx ey)
horizontalPath = Line (Point sx my, Point ex my)
slantLeftPath = Line (Point sx sy, Point ex ey)
slantRightPath = Line (Point sx ey, Point ex sy)
in
[
(Piece Mid Horizontal Solid
,[Line (Point sx my, Point ex my)]
)
,
(Piece Mid Horizontal Dashed
,[DashedLine (Point sx my, Point ex my)]
)
,
(Piece Low Horizontal Solid
,[Line (Point sx ey, Point ex ey)]
)
,
(Piece Low Horizontal Dashed
,[DashedLine (Point sx ey, Point ex ey)]
)
,
(Piece Mid Vertical Solid
,[Line (Point mx sy, Point mx ey)]
)
,
(Piece Mid Vertical Dashed
,[DashedLine (Point mx sy, Point mx ey)]
)
,
(Piece Mid SlantLeft Solid
,[Line (Point sx sy, Point ex ey)]
)
,
(Piece Mid SlantRight Solid
,[Line (Point sx ey, Point ex sy)]
)
,
(Arrow Top
,[ArrowLine (Point mx ey, Point mx sy)]
)
,
(Arrow Bottom
,[ArrowLine (Point mx sy, Point mx ey)]
)
,
(Arrow Left
,[ArrowLine (Point ex my, Point mx my)]
)
,
(Arrow Right
,[ArrowLine (Point sx my, Point mx my)]
)
,
(Arrow TopLeft
,[ArrowLine (Point ex ey, Point qx qy)]
)
,(Arrow TopRight
,[ArrowLine (Point sx ey, Point q3x qy)]
)
,
(Arrow BottomLeft
,[ArrowLine (Point ex sy, Point qx q3y)]
)
,
(Arrow BottomRight
,[ArrowLine (Point sx sy, Point q3x q3y)]
)
,
(Junction Mid [Bottom, Right] Sharp
,[Line (Point mx my, Point ex my)
,Line (Point mx my, Point mx ey)
]
)
,
(Junction Mid [Bottom, Left] Sharp
,[Line (Point sx my, Point mx my)
,Line (Point mx my, Point mx ey)
]
)
,
(Junction Mid [Top, Right] Sharp
,[Line (Point mx sy, Point mx my)
,Line (Point mx my, Point ex my)
]
)
,
(Junction Mid [Top, Left] Sharp
,[Line (Point sx my, Point mx my)
,Line (Point mx my, Point mx sy)
]
)
,
(Junction Mid [Top, Bottom, Right] Sharp
,[Line (Point mx sy, Point mx ey)
,Line (Point mx my, Point ex my)
]
)
,
(Junction Mid [Top, Bottom, Left] Sharp
,[Line (Point mx sy, Point mx ey)
,Line (Point sx my, Point mx my)
]
)
,
(Junction Mid [Top, Left, Right] Sharp
,[Line (Point mx sy, Point mx my)
,Line (Point sx my, Point ex my)
]
)
,
(Junction Mid [Left, Right, Bottom] Sharp
,[Line (Point sx my, Point ex my)
,Line (Point mx my, Point mx ey)
]
)
,
(Junction Mid [Right, BottomLeft] Smooth
,[Arc (Point ex my, Point qx q3y, arcRadius * 2, False)
,Line (Point sx ey, Point qx q3y)
]
)
,
(Junction Mid [Left, BottomRight] Smooth
,[Arc (Point q3x q3y, Point sx my, arcRadius * 2, False)
,Line (Point ex ey, Point q3x q3y)
]
)
,
(Junction Mid [Right, TopLeft] Smooth
,[Arc (Point qx qy, Point ex my, arcRadius * 2, False)
,Line (Point sx sy, Point qx qy)
]
)
,
{--
/
-'
--}
(Junction Mid [Left, TopRight] Smooth
,[Arc (Point sx my, Point q3x qy, arcRadius * 2, False)
,Line (Point q3x qy, Point ex sy)
]
)
,
{--
/
'-
--}
(Junction Mid [Right, TopRight] Smooth
,[Arc (Point q3x qy, Point ex my, arcRadius, False)
,Line (Point q3x qy, Point ex sy)
]
)
,
{--
\
-'
--}
(Junction Mid [Left, TopLeft] Smooth
,[Arc (Point qx qy, Point sx my, arcRadius, True)
,Line (Point qx qy, Point sx sy)
]
)
,
{--
-.
/
--}
(Junction Mid [Left, BottomLeft] Smooth
,[Arc (Point qx q3y, Point sx my, arcRadius, False)
,Line (Point sx ey, Point qx q3y)
]
)
,
{--
.-
\
--}
(Junction Mid [Right, BottomRight] Smooth
,[Arc (Point q3x q3y, Point ex my, arcRadius, True)
,Line (Point q3x q3y, Point ex ey)
]
)
,
{--
\
.
|
--}
(Junction Mid [Bottom, TopLeft] Smooth
,[Line (Point mx ey, Point mx q3y)
,Arc (Point mx q3y, Point qx qy, arcRadius * 4, False)
,Line (Point qx qy, Point sx sy)
]
)
,
{--
|
.
\
--}
(Junction Mid [Top, BottomRight] Smooth
,[Line (Point mx sy, Point mx qy)
,Arc (Point mx qy, Point q3x q3y, arcRadius * 4, False)
,Line (Point q3x q3y, Point ex ey)
]
)
,
(Junction Mid [Top, Left, Bottom, Right] Sharp
,[Line (Point sx my, Point ex my)
,Line (Point mx sy, Point mx ey)
]
)
,(Junction Mid
[Top, Left, Bottom, Right
,TopLeft, TopRight, BottomLeft, BottomRight
] Sharp
,[Line (Point sx my, Point ex my)
,Line (Point mx sy, Point mx ey)
,Line (Point sx sy, Point ex ey)
,Line (Point sx ey, Point ex sy)
]
)
{--
.-
|
--}
,
(Junction Mid [Bottom, Right] Smooth
,[ Arc (Point ex my, Point mx q3y, arcRadius, False)
,Line (Point mx q3y, Point mx ey)
]
)
{--
.-
|
--}
,(Junction Mid [Bottom, Left] Smooth
,[ Arc (Point mx q3y, Point sx my, arcRadius, False)
,Line (Point mx q3y, Point mx ey)
]
)
,
{--
|
'-
--}
(Junction Mid [Top, Right] Smooth
,[ Arc (Point mx qy, Point ex my, arcRadius, False)
,Line (Point mx sy, Point mx qy)
]
)
{--
|
-'
--}
,(Junction Mid [Top, Left] Smooth
,[ Arc (Point sx my, Point mx qy, arcRadius, False)
,Line (Point mx sy, Point mx qy)
]
)
,
{--
|
._
--}
(Junction Low [Top, Right] Smooth
, [Line (Point mx sy, Point mx q3y)
,Arc (Point mx q3y, Point ex ey, arcRadius, False)
]
)
,
{--
|
_.
--}
(Junction Low [Top, Left] Smooth
, [
Arc (Point sx ey, Point mx q3y, arcRadius, False)
,Line (Point mx q3y, Point mx sy)
]
)
,
{--
_
|
--}
(Action Low LowHorizontal Extend Left Half
,[Line (Point ex ey, Point (sx - tw2) ey)
]
)
,
{--
/_
--}
(Action Low LowHorizontal Extend Left Full
,[Line (Point ex ey, Point (sx - textWidth) ey)
]
)
,
{--
_\
--}
(Action Low LowHorizontal Extend Right Full
,[Line (Point sx ey, Point (ex + textWidth) ey)
]
)
,
{--
_
|
--}
(Action Low LowHorizontal Extend Right Half
, [Line (Point sx ey, Point (ex + tw2) ey) ]
)
,
{--
/
.-
/
--}
(Junction Mid [Right, TopRight, BottomLeft] Smooth
,[ Line (Point sx ey, Point ex sy)
,Arc (Point ex my, Point qx q3y, arcRadius * 2, False)
]
)
,
{--
\
.-
\
--}
(Junction Mid [Right, TopLeft, BottomRight] Smooth
, [Line (Point sx sy, Point ex ey)
,Line (Point ex my, Point q3x my)
,Arc (Point qx qy, Point q3x my, arcRadius * 2, False)
]
)
,
{--
|
.
/|
--}
(Junction Mid [Top, Bottom, BottomLeft] Smooth
,[Line (Point mx sy, Point mx ey)
,Line (Point sx ey, Point qx q3y)
,Arc (Point qx q3y, Point mx qy, arcRadius * 4, False)
]
)
,
{--
/
.
|
--}
(Junction Mid [Bottom, TopRight] Smooth
, [Line (Point ex sy, Point q3x qy)
,Arc (Point q3x qy, Point mx q3y, arcRadius * 4, False)
,Line (Point mx ey, Point mx q3y)
]
)
,
{--
|
.
/
--}
(Junction Mid [Top, BottomLeft] Smooth
, [
Line (Point sx ey, Point qx q3y)
,Arc (Point qx q3y, Point mx qy, arcRadius * 4, False)
,Line (Point mx sy, Point mx qy)
]
)
,
{--
\
.
/
--}
(Junction Mid [TopLeft, BottomLeft] Smooth
, [Line (Point sx sy, Point qx qy)
,Arc (Point qx q3y, Point qx qy, arcRadius * 2, False)
,Line (Point sx ey, Point qx q3y)
]
)
,
{--
/
.
\
--}
(Junction Mid [TopRight, BottomRight] Smooth
, [ Line (Point ex sy, Point q3x qy)
, Arc (Point q3x qy, Point q3x q3y, arcRadius * 2, False)
, Line (Point q3x q3y, Point ex ey)
]
)
,
{--
/
(
\
--}
(Curve Left Mid Quarter
,[Arc (Point ex sy, Point ex ey, arcRadius * 4, False)]
)
,
{--
\
)
/
--}
(Curve Right Mid Quarter
, [Arc (Point sx ey, Point sx sy, arcRadius * 4, False)]
)
,
{--
.-.
--}
(Curve Top Mid Half
, [Arc (Point ex my, Point sx my, arcRadius * 4, False)
]
)
,
{--
.
(
'
--}
(Curve Left Mid Half
, [Arc (Point q3x sy, Point q3x ey, arcRadius * 4, False)
]
)
,
{--
.
)
'
--}
(Curve Right Mid Half
, [Arc (Point qx sy, Point qx ey, arcRadius * 4, True)
]
)
,
{--
'-'
--}
(Curve Bottom Mid Half
, [Arc (Point sx my, Point ex my, arcRadius * 4, False)
]
)
,
{---
.-
(
--}
(Curve TopLeft Mid Half
,[Arc (Point ex my, Point (sx-tw4) ey, arcRadius * 4, False)]
)
,
{---
-.
)
--}
(Curve TopRight Mid Half
,[Arc (Point sx my, Point (ex+tw4) ey, arcRadius * 4, True)]
)
,
{---
(
'-
--}
(Curve BottomLeft Mid Half
, [Arc (Point (sx-tw4) sy, Point ex my, arcRadius * 4, False)
]
)
,
{---
)
-'
--}
(Curve BottomRight Mid Half
, [Arc (Point sx my, Point (ex+tw4) sy, arcRadius * 4, False)
]
)
,
{--
\|/ \|/ \|/
+ * .
/|\ /|\ /|\
--}
(Junction Mid [Top, Bottom, TopLeft, TopRight, BottomLeft, BottomRight] Sharp
,[verticalPath
,slantLeftPath
,slantRightPath
]
)
]
--check if the 3 points lie on the same line
collinear: Point -> Point -> Point -> Bool
collinear p1 p2 p3 =
let
ax = p1.x
ay = p1.y
bx = p2.x
by = p2.y
cx = p3.x
cy = p3.y
in
ax * (by - cy) + bx * (cy - ay) + cx * (ay - by) == 0
-- simply check is path1 end == path2 start
canConcat: Path -> Path -> Bool
canConcat path1 path2 =
case path1 of
Line (s, e) ->
case path2 of
Line (s2, e2) ->
e == s2
Arc (s2, e2, r2, sweep) ->
e == s2
_ ->
False
Arc (s, e, r, sweep) ->
case path2 of
Line (s2, e2) ->
e == s2
Arc (s2, e2, r2, sweep) ->
e == s2
_ ->
False
DashedLine (s, e) ->
case path2 of
DashedLine (s2, e2) ->
e == s2
_ ->
False
ArrowLine (s, e) ->
False
TextPath (s, string) ->
False
-- only lines can eat another line
-- can eat if path1 ends = path2 start and the lie on the same line
-- returns a new Path with path1 start and path2 end
eat: Path -> Path -> Maybe Path
eat path1 path2 =
case path1 of
Line (s, e) ->
case path2 of
Line (s2, e2) ->
if e == s2 && collinear s e e2 then
Just <| Line (s, e2)
else
Nothing
_ ->
Nothing
DashedLine (s, e) ->
case path2 of
DashedLine (s2, e2) ->
if e == s2 && collinear s e e2 then
Just <| DashedLine (s, e2)
else
Nothing
_ ->
Nothing
_ ->
Nothing
canReduce: (Int, Int) -> (Int, Int) -> Model -> Bool
canReduce (x1, y1) (x2, y2) model =
case tryReduce (x1, y1) (x2, y2) model of
Just can ->
True
Nothing ->
False
--arrow lines can not b reduce
isReduceable: Maybe Component -> Bool
isReduceable comp =
case comp of
Just comp ->
case comp of
Arrow _ ->
False
_ ->
True
Nothing ->
False
tryReduce: (Int, Int) -> (Int, Int) -> Model -> Maybe Path
tryReduce (x1, y1) (x2, y2) model =
let
comp1 = matchComponent x1 y1 model
comp2 = matchComponent x2 y2 model
in
-- can not reduce arrow lines
if isReduceable comp2 then
case comp1 of
Just comp1 ->
case comp2 of
Just comp2 ->
let
path1 = firstPathOnly x1 y1 comp1 model
path2 = firstPathOnly x2 y2 comp2 model
in
case path1 of
Just path1 ->
case path2 of
Just path2 ->
reduce path1 path2
Nothing ->
Nothing
Nothing ->
Nothing
Nothing ->
Nothing
Nothing ->
Nothing
else
Nothing
-- eat with trial on which arrangement
reduce: Path -> Path -> Maybe Path
reduce path1 path2 =
case eat path1 path2 of
Just path12 ->
Just path12
Nothing ->
case eat path1 (reversePath path2) of
Just path1Rev2 ->
Just path1Rev2
Nothing ->
Nothing
-- if has only 1 path return it
firstPathOnly: Int -> Int -> Component -> Model -> Maybe Path
firstPathOnly x y comp model =
let paths = getComponentPaths x y comp model
in
if List.length paths == 1 then
List.head paths
else
Nothing
-- if this component is isEdible, then don't mind plotting it
-- since it something would eat it along the way
-- if it is in between component that could eat it
-- deal only with simple elements
isEdible: Int -> Int -> Model -> Bool
isEdible x y model =
let
center = (x,y)
top = (x, y-1)
bottom = (x, y+1)
left = (x-1, y)
topLeft = (x-1, y-1)
bottomLeft = (x-1, y+1)
match =
[canReduce top center model
,canReduce left center model
,canReduce topLeft center model
,canReduce bottomLeft center model
]
in
List.any (\a -> a) match
vertical = ['|']
verticalDashed = [':']
horizontal = ['-']
horizontalDashed = ['=']
lowHorizontal = ['_']
intersection = ['+']
asterisk = ['*']
round = ['.','\'']
roundLow = ['.']
roundHigh= ['\'']
arrowRight = ['>']
arrowDown = ['V','v']
arrowLeft = ['<']
arrowUp = ['^','î']
slantRight = ['/']
slantLeft = ['\\']
openCurve = ['(']
closeCurve = [')']
get: Int -> Int -> Model -> Maybe Char
get x y model =
let
row = y
line: Maybe (Array Char)
line = Array.get y model.lines
char: Maybe Char
char =
case line of
Just l ->
Array.get x l
Nothing ->
Nothing
in
char
isOpenCurve char =
List.member char openCurve
--close parenthesis
isCloseCurve char =
List.member char closeCurve
isVertical char =
List.member char vertical
isVerticalDashed char =
List.member char verticalDashed
isHorizontalDashed char =
List.member char horizontalDashed
isAlphaNumeric char =
Char.isDigit char || Char.isUpper char || Char.isLower char
isHorizontal char =
List.member char horizontal
isLowHorizontal char =
List.member char lowHorizontal
isIntersection char =
List.member char intersection
isAsterisk char =
List.member char asterisk
isLine char =
isVertical char || isHorizontal char || isLowHorizontal char
isRound char =
List.member char round
isRoundLow char =
List.member char roundLow
isRoundHigh char =
List.member char roundHigh
isChar: Maybe Char -> (Char -> Bool) -> Bool
isChar char check =
case char of
Just char ->
check char
Nothing ->
False
isArrowRight char =
List.member char arrowRight
isArrowLeft char =
List.member char arrowLeft
isArrowDown char =
List.member char arrowDown
isArrowUp char =
List.member char arrowUp
isSlantRight char =
List.member char slantRight
isSlantLeft char =
List.member char slantLeft
leftOf x y model =
get (x-1) y model
rightOf x y model =
get (x+1) y model
topOf x y model =
get x (y-1) model
bottomOf x y model =
get x (y+1) model
topLeftOf x y model =
get (x-1) (y-1) model
topRightOf x y model =
get (x+1) (y-1) model
bottomLeftOf x y model =
get (x-1) (y+1) model
bottomRightOf x y model =
get (x+1) (y+1) model
isNeighbor neighbor check =
case neighbor of
Just neighbor ->
check neighbor
Nothing ->
False
-- conditions to match and the corresponding component
-- arrange from simple to most complex
-- low priority to higher priority, the list is reveres before using for matching
componentMatchList: Int -> Int -> Model -> List (Bool, Component)
componentMatchList x y model =
let
char = get x y model
top = topOf x y model
bottom = bottomOf x y model
left = leftOf x y model
right = rightOf x y model
topLeft = topLeftOf x y model
topRight = topRightOf x y model
bottomLeft = bottomLeftOf x y model
bottomRight = bottomRightOf x y model
in
[
{--
|
--}
(isChar char isVertical && not (isNeighbor left isAlphaNumeric) && not (isNeighbor right isAlphaNumeric)
,Piece Mid Vertical Solid
)
,
{--
-
--}
(isChar char isHorizontal && not (isNeighbor left isAlphaNumeric) && not (isNeighbor right isAlphaNumeric)
,Piece Mid Horizontal Solid
)
,
{--
_
--}
(isChar char isLowHorizontal && not (isNeighbor left isAlphaNumeric) && not (isNeighbor right isAlphaNumeric)
,Piece Low Horizontal Solid
)
,
(isChar char isSlantLeft && not (isNeighbor left isAlphaNumeric) && not (isNeighbor right isAlphaNumeric)
,Piece Mid SlantLeft Solid
)
,
(isChar char isSlantRight && not (isNeighbor left isAlphaNumeric) && not (isNeighbor right isAlphaNumeric)
,Piece Mid SlantRight Solid
)
,
{--
:
--}
(isChar char isVerticalDashed && not (isNeighbor left isAlphaNumeric) && not (isNeighbor right isAlphaNumeric)
,Piece Mid Vertical Dashed
)
,
{--
:
--}
(isChar char isHorizontalDashed && not (isNeighbor left isAlphaNumeric) && not (isNeighbor right isAlphaNumeric)
,Piece Mid Horizontal Dashed
)
,
{--
^
|
--}
(isChar char isArrowUp
&&isNeighbor bottom isVertical && not (isNeighbor left isAlphaNumeric) && not (isNeighbor right isAlphaNumeric)
,Arrow Top
)
,
{--
<-
--}
(isChar char isArrowLeft
&&isNeighbor right isHorizontal && not (isNeighbor left isAlphaNumeric) && not (isNeighbor right isAlphaNumeric)
,Arrow Left
)
,
{--
->
--}
(isChar char isArrowRight
&&isNeighbor left isHorizontal && not (isNeighbor left isAlphaNumeric) && not (isNeighbor right isAlphaNumeric)
,Arrow Right
)
,
{--
|
V
--}
(isChar char isArrowDown
&&isNeighbor top isVertical && not (isNeighbor left isAlphaNumeric) && not (isNeighbor right isAlphaNumeric)
,Arrow Bottom
)
,
{--
^
\
--}
(isChar char isArrowUp
&&isNeighbor bottomRight isSlantLeft && not (isNeighbor left isAlphaNumeric) && not (isNeighbor right isAlphaNumeric)
,Arrow TopLeft
)
,
{--
/
v
--}
(isChar char isArrowDown
&&isNeighbor topRight isSlantRight && not (isNeighbor left isAlphaNumeric) && not (isNeighbor right isAlphaNumeric)
,Arrow BottomLeft
)
,
{--
\
v
--}
(isChar char isArrowDown
&&isNeighbor topLeft isSlantLeft && not (isNeighbor left isAlphaNumeric) && not (isNeighbor right isAlphaNumeric)
,Arrow BottomRight
)
,
{--
^
/
--}
(isChar char isArrowUp
&&isNeighbor bottomLeft isSlantRight && not (isNeighbor left isAlphaNumeric) && not (isNeighbor right isAlphaNumeric)
,Arrow TopRight
)
,
{--
+-
|
--}
(isChar char isIntersection
&& isNeighbor right isHorizontal
&& isNeighbor bottom isVertical
,Junction Mid [Bottom, Right] Sharp
)
,
{--
-+
|
--}
(isChar char isIntersection
&& isNeighbor left isHorizontal
&& isNeighbor bottom isVertical
,Junction Mid [Bottom, Left] Sharp
)
,
{--
|
+-
--}
(isChar char isIntersection
&& isNeighbor right isHorizontal
&& isNeighbor top isVertical
,Junction Mid [Top, Right] Sharp
)
,
{--
|
-+
--}
(isChar char isIntersection
&& isNeighbor left isHorizontal
&& isNeighbor top isVertical
,Junction Mid [Top, Left] Sharp
)
,
{--
.-
/
--}
(isChar char isRound
&& isNeighbor right isHorizontal
&& isNeighbor bottomLeft isSlantRight
,Junction Mid [Right, BottomLeft] Smooth
)
,
{--
-.
\
--}
(isChar char isRound
&& isNeighbor left isHorizontal
&& isNeighbor bottomRight isSlantLeft
,Junction Mid [Left, BottomRight] Smooth
)
,
{--
\
'-
--}
(isChar char isRound
&& isNeighbor right isHorizontal
&& isNeighbor topLeft isSlantLeft
,Junction Mid [Right, TopLeft] Smooth
)
,
{--
/
-'
--}
(isChar char isRound
&& isNeighbor left isHorizontal
&& isNeighbor topRight isSlantRight
,Junction Mid [Left, TopRight] Smooth
)
,
{--
/
'-
--}
(isChar char isRound
&& isNeighbor right isHorizontal
&& isNeighbor topRight isSlantRight
,Junction Mid [Right, TopRight] Smooth
)
,
{--
\
-'
--}
(isChar char isRound
&& isNeighbor left isHorizontal
&& isNeighbor topLeft isSlantLeft
,Junction Mid [Left, TopLeft] Smooth
)
,
{--
-.
/
--}
(isChar char isRound
&& isNeighbor left isHorizontal
&& isNeighbor bottomLeft isSlantRight
,Junction Mid [Left, BottomLeft] Smooth
)
,
{--
.-
\
--}
(isChar char isRound
&& isNeighbor right isHorizontal
&& isNeighbor bottomRight isSlantLeft
,Junction Mid [Right, BottomRight] Smooth
)
,
{--
/
.
|
--}
(isChar char isRound
&& isNeighbor bottom isVertical
&& isNeighbor topRight isSlantRight
,Junction Mid [Bottom, TopRight] Smooth
)
,
{--
\
.
|
--}
(isChar char isRound
&& isNeighbor bottom isVertical
&& isNeighbor topLeft isSlantLeft
,Junction Mid [Bottom, TopLeft] Smooth
)
,
{--
|
.
/
--}
(isChar char isRound
&& isNeighbor top isVertical
&& isNeighbor bottomLeft isSlantRight
,Junction Mid [Top, BottomLeft] Smooth
)
,
{--
\
.
/
--}
(isChar char isRound
&& isNeighbor topLeft isSlantLeft
&& isNeighbor bottomLeft isSlantRight
,Junction Mid [TopLeft, BottomLeft] Smooth
)
,
{--
/
.
\
--}
(isChar char isRound
&& isNeighbor topRight isSlantRight
&& isNeighbor bottomRight isSlantLeft
,Junction Mid [TopRight, BottomRight] Smooth
)
,
{--
|
.
\
--}
(isChar char isRound
&& isNeighbor top isVertical
&& isNeighbor bottomRight isSlantLeft
,Junction Mid [Top, BottomRight] Smooth
)
,
{--
/
(
\
--}
(isChar char isOpenCurve
&& isNeighbor topRight isSlantRight
&& isNeighbor bottomRight isSlantLeft
,Curve Left Mid Quarter
)
,
{--
\
)
/
--}
(isChar char isCloseCurve
&& isNeighbor topLeft isSlantLeft
&& isNeighbor bottomLeft isSlantRight
,Curve Right Mid Quarter
)
,
{---
.-.
--}
(isChar char isHorizontal
&& isNeighbor left isRoundLow
&& isNeighbor right isRoundLow
,Curve Top Mid Half
)
,
{---
'-'
--}
(isChar char isHorizontal
&& isNeighbor left isRoundHigh
&& isNeighbor right isRoundHigh
,Curve Bottom Mid Half
)
,
{---
.
(
'
--}
(isChar char isOpenCurve
&& isNeighbor topRight isRound
&& isNeighbor bottomRight isRound
,Curve Left Mid Half
)
,
{---
.
)
'
--}
(isChar char isCloseCurve
&& isNeighbor topLeft isRound
&& isNeighbor bottomLeft isRound
,Curve Right Mid Half
)
,
{---
.-
(
--}
(isChar char isRoundLow
&& isNeighbor right isHorizontal
&& isNeighbor bottomLeft isOpenCurve
,Curve TopLeft Mid Half
)
,
{---
-.
)
--}
(isChar char isRoundLow
&& isNeighbor left isHorizontal
&& isNeighbor bottomRight isCloseCurve
,Curve TopRight Mid Half
)
,
{---
(
'-
--}
(isChar char isRoundHigh
&& isNeighbor right isHorizontal
&& isNeighbor topLeft isOpenCurve
,Curve BottomLeft Mid Half
)
,
{---
)
-'
--}
(isChar char isRoundHigh
&& isNeighbor left isHorizontal
&& isNeighbor topRight isCloseCurve
,Curve BottomRight Mid Half
)
,
(isChar char isRound
&& isNeighbor right isHorizontal
&& isNeighbor bottom isVertical
,Junction Mid [Bottom, Right] Smooth
)
,
(isChar char isRound
&& isNeighbor left isHorizontal
&& isNeighbor bottom isVertical
,Junction Mid [Bottom, Left] Smooth
)
,
{--
|
'-
--}
(isChar char isRound
&& isNeighbor right isHorizontal
&& isNeighbor top isVertical
,Junction Mid [Top, Right] Smooth
)
{--
|
-'
--}
,
(isChar char isRound
&& isNeighbor left isHorizontal
&& isNeighbor top isVertical
,Junction Mid [Top, Left] Smooth
)
,
{--
|
._
--}
(isChar char isRound
&& isNeighbor right isLowHorizontal
&& isNeighbor top isVertical
,Junction Low [Top, Right] Smooth
)
,
{--
|
_.
--}
(isChar char isRound
&& isNeighbor left isLowHorizontal
&& isNeighbor top isVertical
,Junction Low [Top, Left] Smooth
)
,
{--
_
|
--}
(isChar char isLowHorizontal
&& isNeighbor bottomLeft isVertical
,Action Low LowHorizontal Extend Left Half
)
,
{--
_
|
--}
(isChar char isLowHorizontal
&& isNeighbor bottomRight isVertical
,Action Low LowHorizontal Extend Right Half
)
,
{--
_|
--}
(isChar char isLowHorizontal
&& isNeighbor right isVertical
,Action Low LowHorizontal Extend Right Half
)
,
{--
|_
--}
(isChar char isLowHorizontal
&& isNeighbor left isVertical
,Action Low LowHorizontal Extend Left Half
)
,
{--
/_
--}
(isChar char isLowHorizontal
&& isNeighbor left isSlantRight
,Action Low LowHorizontal Extend Left Full
)
,
{--
_\
--}
(isChar char isLowHorizontal
&& isNeighbor right isSlantLeft
,Action Low LowHorizontal Extend Right Full
)
,
{--
|
+-
|
--}
(isChar char isIntersection
&& isNeighbor right isHorizontal
&& isNeighbor top isVertical
&& isNeighbor bottom isVertical
,Junction Mid [Top, Bottom, Right] Sharp
)
,
{--
|
-+
|
--}
(isChar char isIntersection
&& isNeighbor left isHorizontal
&& isNeighbor top isVertical
&& isNeighbor bottom isVertical
,Junction Mid [Top, Bottom, Left] Sharp
)
,
{--
|
-+-
--}
(isChar char isIntersection
&& isNeighbor left isHorizontal
&& isNeighbor top isVertical
&& isNeighbor right isHorizontal
,Junction Mid [Top, Left, Right] Sharp
)
,
{--
-+-
|
--}
(isChar char isIntersection
&& isNeighbor left isHorizontal
&& isNeighbor right isHorizontal
&& isNeighbor bottom isVertical
,Junction Mid [Left, Right, Bottom] Sharp
)
,
{--
/
.-
/
--}
(isChar char isRound
&& isNeighbor topRight isSlantRight
&& isNeighbor bottomLeft isSlantRight
&& isNeighbor right isHorizontal
,Junction Mid [Right, TopRight, BottomLeft] Smooth
)
,
{--
\
.-
\
--}
(isChar char isRound
&& isNeighbor topLeft isSlantLeft
&& isNeighbor bottomRight isSlantLeft
&& isNeighbor right isHorizontal
,Junction Mid [Right, TopLeft, BottomRight] Smooth
)
,
{--
|
.
/|
--}
(isChar char isRound
&& isNeighbor top isVertical
&& isNeighbor bottom isVertical
&& isNeighbor bottomLeft isSlantRight
,Junction Mid [Top, Bottom, BottomLeft] Smooth
)
,
{--
|
-+-
|
--}
(isChar char isIntersection
&& isNeighbor top isVertical
&& isNeighbor left isHorizontal
&& isNeighbor bottom isVertical
&& isNeighbor right isHorizontal
,Junction Mid [Top, Left, Bottom, Right] Sharp
)
,
{--
\|/ \|/ \|/
+ * .
/|\ /|\ /|\
--}
((isChar char isIntersection || isChar char isRound || isChar char isAsterisk)
&& isNeighbor top isVertical
&& isNeighbor bottom isVertical
&& isNeighbor topLeft isSlantLeft
&& isNeighbor topRight isSlantRight
&& isNeighbor bottomLeft isSlantRight
&& isNeighbor bottomRight isSlantLeft
,Junction Mid [Top, Bottom, TopLeft, TopRight, BottomLeft, BottomRight] Sharp
)
,
{--
\|/ \|/ \|/
-+- -*- -.-
/|\ /|\ /|\
--}
((isChar char isIntersection || isChar char isRound || isChar char isAsterisk)
&& isNeighbor top isVertical
&& isNeighbor left isHorizontal
&& isNeighbor bottom isVertical
&& isNeighbor right isHorizontal
&& isNeighbor topLeft isSlantLeft
&& isNeighbor topRight isSlantRight
&& isNeighbor bottomLeft isSlantRight
&& isNeighbor bottomRight isSlantLeft
,Junction Mid [Top, Left, Bottom, Right, TopLeft, TopRight, BottomLeft, BottomRight] Sharp
)
]
isNotSpace: Char -> Bool
isNotSpace char =
char /= ' '
matchComponent: Int -> Int -> Model -> Maybe Component
matchComponent x y model =
let char = get x y model
comp =
componentMatchList x y model
|> List.reverse
|> List.filterMap
(\(match, comp) ->
if match then
Just comp
else
Nothing
)
|> List.head
in
case comp of
Just comp ->
Just comp
Nothing ->
if isChar char isNotSpace then
let _ = Debug.log "Matching component to char" char
in
Just <| Text (Maybe.withDefault ' ' char)
else
Nothing
getSvg model =
let
gwidth = toString <| (measureX model.columns)
gheight = toString <| (measureY model.rows)
svgPaths =
case density of
Compact ->
let
(pathDefs,unmerged) = allPathDefs model
onePath = drawPathDef pathDefs Solid None
unmergedPaths =
List.map (
\um ->
svgPath um
) unmerged
in
onePath::unmergedPaths
Medium ->
let
(pathDefs, unmerged) =
perComponentPathDefs model
|> List.unzip
svgPathDefs =
pathDefs
|> List.map (
\(defs) ->
if String.isEmpty defs then
Nothing
else
Just <| drawPathDef defs Solid None
)
|> List.filterMap (\a -> a)
unmergedPaths =
List.concat unmerged
|> List.map (
\um ->
svgPath um
)
in
svgPathDefs ++ unmergedPaths
Expanded ->
expandedPaths model
|> List.map
(\path ->
svgPath path
)
{--
svgTexts = getTexts model
|> List.map
(\(x, y, chars) ->
svgText x y chars
)
--}
in
svg [--xmlns "http://www.w3.org/2000/svg"
height gheight, width gwidth
,Svg.Attributes.style ("font-size:"++toString fontSize++"px;font-family:monospace")
]
([
if gridOn then
gridFill
else
[]
,[defs [] [arrowMarker]]
,svgPaths
--,svgTexts
] |> List.concat
)
svgText: Int -> Int -> String -> Svg a
svgText xloc yloc chars =
let sx = measureX xloc - textWidth / 4
sy = measureY yloc + textHeight * 3 / 4
in
Svg.text'
[x (toString sx)
,y (toString sy)
]
[Svg.text chars
]
drawText: Point -> String -> Svg a
drawText point chars =
let sx = point.x
sy = point.y
in
Svg.text'
[x (toString sx)
,y (toString sy)
]
[Svg.text chars
]
allPathDefs: Model -> (String, List Path)
allPathDefs model =
let (pathDefs, unmerged) =
List.unzip <| perComponentPathDefs model
in
(String.join " " pathDefs
,List.concat unmerged
)
perComponentPathDefs: Model -> List (String, List Path)
perComponentPathDefs model =
Array.indexedMap
(\y line ->
Array.indexedMap
(\ x char->
componentPathDefs x y model
) line
|> Array.toList
) model.lines
|> Array.toList
|> List.concat
|> List.filterMap (\a->a)
expandedPaths: Model -> List Path
expandedPaths model =
Array.indexedMap
(\y line ->
Array.indexedMap
(\ x char->
componentPaths x y model
) line
|> Array.toList
) model.lines
|> Array.toList
|> List.concat
|> List.concat
getTexts: Model -> List (Int,Int,String)
getTexts model =
Array.indexedMap
(\y line ->
Array.indexedMap
(\ x char->
if isPartOfText x y model then
Nothing
else
let traced = traceText x y model ""
in
if String.isEmpty traced then
Nothing
else
Just (x, y, traced)
) line
|> Array.toList
) model.lines
|> Array.toList
|> List.concat
|> List.filterMap(\a -> a)
mergeText: String -> Maybe Char -> String
mergeText text char =
case char of
Just char ->
text ++ (String.fromChar char)
Nothing ->
text
--v V
usedAsArrow x y model =
let char = get x y model
top = get x (y-1) model
topLeft = get (x-1) (y-1) model
topRight = get (x+1) (y-1) model
in
isChar char isArrowDown
&&
( isNeighbor top isVertical
|| isNeighbor topLeft isSlantLeft
|| isNeighbor topRight isSlantRight
)
-- if this text is part of text, ignore it
isPartOfText: Int -> Int -> Model -> Bool
isPartOfText x y model =
let
char = get x y model
right = get (x+1) y model
left = get (x-1) y model
wordSpace =
isChar char (\a -> a == ' ')
&& isChar right isAlphaNumeric
&& isChar left isAlphaNumeric
in
(isChar char isAlphaNumeric
&& isNeighbor left isAlphaNumeric
)
traceText: Int -> Int -> Model -> String -> String
traceText x y model prevChars =
let
char = get x y model
right = get (x+1) y model
left = get (x-1) y model
wordSpace =
isChar char (\a -> a == ' ')
&& isChar right isAlphaNumeric
&& isChar left isAlphaNumeric
in
if (isChar char isAlphaNumeric
&& not (usedAsArrow x y model) --v V used as arrows
) then
traceText (x+1) y model (mergeText prevChars char)
else
prevChars
--reduce path to whatever is located in x y
reduceTo: Path -> (Int, Int) -> Model -> Maybe Path
reduceTo path (x, y) model =
case matchComponent x y model of
Just comp ->
case firstPathOnly x y comp model of
Just firstPath ->
reduce path firstPath
Nothing ->
Nothing
Nothing ->
Nothing
--trace a path starting at this point
--and return the long eating path until a non-isEdible path is encoutered, and eat it as well
-- reduce only from left to right, top to bottom, topLeft to bottomRight
traceEatEdiblePaths: Path -> (Int, Int) -> Model -> Maybe Path
traceEatEdiblePaths path (x,y) model =
let
top = (x, y-1)
bottom = (x, y+1)
left = (x-1, y)
right = (x+1,y)
topLeft = (x-1, y-1)
topRight = (x+1, y-1)
bottomLeft = (x-1, y+1)
bottomRight = (x+1, y+1)
in
case reduceTo path right model of
Just reducedRight ->
traceEatEdiblePaths reducedRight right model
Nothing ->
case reduceTo path bottom model of
Just reducedBottom ->
traceEatEdiblePaths reducedBottom bottom model
Nothing ->
case reduceTo path bottomRight model of
Just reducedBottomRight ->
traceEatEdiblePaths reducedBottomRight bottomRight model
Nothing ->
case reduceTo path topRight model of
Just reducedTopRight ->
traceEatEdiblePaths reducedTopRight topRight model
Nothing ->
Just path
-- check first if there is component before testing if isEdible
getOptimizedPath x y model =
let center =
matchComponent x y model
in
case center of
Just center ->
if isEdible x y model then
[]
else
case firstPathOnly x y center model of
Just firstPath ->
case traceEatEdiblePaths firstPath (x, y) model of
Just path ->
[path]
Nothing ->
[]
Nothing ->
getComponentPaths x y center model
Nothing ->
[]
startEnd: Path -> (Point, Point)
startEnd path =
case path of
Line se -> se
Arc (s, e, r, sw) -> (s, e)
ArrowLine se -> se
DashedLine se -> se
TextPath (s,string) -> (s,s)
-- merge the paths into 1 path definition
toPathDefs: List Path -> (String, List Path)
toPathDefs paths =
let (prev', pathDefs', unmergedPaths') =
List.foldl
(\next (prev, str, unmergedPaths) ->
let (start, end) = startEnd next
continue =
case next of
Line (s,e) ->
["L", toString e.x, toString e.y]
Arc (s,e,r,sw) ->
let
sweep = if sw then "1" else "0"
in
["A", toString r, toString r, "0" ,"0", sweep, toString e.x, toString e.y]
_ ->
[]
notMerged =
case next of
ArrowLine _ ->
[next]
DashedLine (s,e) ->
[next]
TextPath (s, string) ->
[next]
_ ->
[]
movePen = ["M", toString start.x, toString start.y]
pathDefs =
case prev of
Just prev ->
if canConcat prev next then
continue |> String.join " "
else
(movePen ++ continue ) |> String.join " "
Nothing ->
(movePen ++ continue) |> String.join " "
in
(Just next
,str ++ pathDefs
,unmergedPaths ++ notMerged
)
) (Nothing, "", []) paths
in
(pathDefs', unmergedPaths')
drawPathDef: String -> Stroke -> Feature -> Svg a
drawPathDef pathDefs lineStroke feature =
let
{red,green,blue,alpha} = Color.toRgb color
colorText = "rgb("++(toString red)++","++(toString green)++","++(toString blue)++")"
dashed =
case lineStroke of
Solid ->
Svg.Attributes.string ""
Dashed ->
strokeDasharray "3 3"
arrow =
case feature of
Arrowed ->
markerEnd "url(#triangle)"
None ->
Svg.Attributes.string ""
in
path [d pathDefs, stroke colorText
,strokeWidth <| toString lineWidth
,fill "transparent"
,dashed
,arrow
]
[]
componentPathDefs: Int -> Int -> Model -> Maybe (String, List Path)
componentPathDefs x y model =
let
pathList = componentPaths x y model
in
if List.isEmpty pathList then
Nothing
else
Just <| toPathDefs pathList
componentPaths: Int -> Int -> Model -> List Path
componentPaths x y model =
case matchComponent x y model of
Just component ->
let
paths =
if optimizeSvg then
getOptimizedPath x y model
else
getComponentPaths x y component model
in
paths
Nothing ->
[]
getComponentPaths: Int -> Int -> Component -> Model -> List Path
getComponentPaths x y component model =
let char = get x y model
path =
List.filterMap(
\ (comp, path) ->
if component == comp then
Just path
else
Nothing
) ( componentPathList x y)
|> List.head
in
case path of
Just path ->
path
Nothing ->
if isChar char isNotSpace then
let _ = Debug.log "Matching component to char" char
in
[TextPath ((Point (measureX x + textWidth / 4) (measureY y + textHeight * 3 / 4)), String.fromChar (Maybe.withDefault ' ' char))]
else
[]
type Feature
= Arrowed
| None
svgPath: Path -> Svg a
svgPath path =
case path of
Line (s, e) ->
drawPathLine s e Solid None
ArrowLine (s, e) ->
drawPathLine s e Solid Arrowed
Arc (s, e, r, sweep) ->
drawArc s e r sweep
DashedLine (s, e) ->
drawPathLine s e Dashed None
TextPath (s, string) ->
drawText s string
reversePath: Path -> Path
reversePath path =
case path of
Line (s, e) ->
Line (e, s)
ArrowLine (s, e) ->
ArrowLine (e, s)
Arc (s, e, r, sweep) ->
Arc (e, s, r, not sweep)
DashedLine (s, e) ->
DashedLine (e, s)
TextPath (s, string) ->
TextPath (s, string)
drawLine: Point -> Point -> Stroke -> Feature -> Svg a
drawLine start end lineStroke feature =
let
{red,green,blue,alpha} = Color.toRgb color
colorText = "rgb("++(toString red)++","++(toString green)++","++(toString blue)++")"
sx = start.x
sy = start.y
ex = end.x
ey = end.y
in
line
[x1 <| toString sx
,y1 <| toString sy
,x2 <| toString ex
,y2 <| toString ey
,stroke colorText
,strokeWidth <| toString lineWidth
,strokeLinecap "round"
,strokeLinejoin "mitter"
,case lineStroke of
Solid ->
strokeDasharray ""
Dashed ->
strokeDasharray "3 3"
,case feature of
Arrowed ->
markerEnd "url(#triangle)"
None ->
markerEnd ""
]
[]
colorText color =
let
{red,green,blue,alpha} = Color.toRgb color
in
"rgb("++(toString red)++","++(toString green)++","++(toString blue)++")"
drawPathLine start end lineStroke feature =
let
sx = start.x
sy = start.y
ex = end.x
ey = end.y
paths =
["M", toString sx, toString sy
,"L", toString ex, toString ey
] |> String.join " "
dashed =
case lineStroke of
Solid ->
strokeDasharray ""
Dashed ->
strokeDasharray "3 3"
arrow =
case feature of
Arrowed ->
markerEnd "url(#triangle)"
None ->
markerEnd ""
in
path [d paths, stroke <| colorText color
,strokeWidth <| toString lineWidth
,fill "none"
,dashed
,arrow
]
[]
drawArc start end radius sweep =
let
rx = radius
ry = radius
sx = start.x
sy = start.y
ex = end.x
ey = end.y
sweepFlag =
if sweep then
"1"
else
"0"
paths =
["M", toString sx, toString sy
,"A", toString rx, toString ry, "0" ,"0", sweepFlag ,toString ex, toString ey
] |> String.join " "
in
path [d paths, stroke <| colorText color, strokeWidth <| toString lineWidth, fill "none"] []
gridFill =
[
defs []
[ pattern [id "smallGrid", height <|toString <| textHeight / 4, patternUnits "userSpaceOnUse", width <| toString <| textWidth / 4 ]
[ path [ d "M 8 0 L 0 0 0 8", fill "none", stroke "gray", strokeWidth "0.1" ]
[]
]
, pattern [ id "grid", height <| toString textHeight, patternUnits "userSpaceOnUse", width <| toString textWidth ]
[ rect [ fill "url(#smallGrid)", height "80", width "80" ]
[]
, path [ d "M 80 0 L 0 0 0 80", fill "none", stroke "gray", strokeWidth "0.25" ]
[]
]
]
,rect [width "100%", height "100%", fill "url(#grid)"] []
]
arrowMarker: Svg a
arrowMarker =
marker [id "triangle"
,viewBox "0 0 14 14"
,refX "0"
,refY "5"
,markerUnits "strokeWidth"
,markerWidth "10"
,markerHeight "10"
,orient "auto"
]
[path [d "M 0 0 L 10 5 L 0 10 z"]
[]
]