Fix alignments/origins and correctly expand for the drawing widget
This commit is contained in:
parent
8458841182
commit
85a00951ba
28
Diagram.hs
28
Diagram.hs
@ -77,17 +77,6 @@ yuD :: DiagProp -> Double
|
|||||||
yuD = snd . dY
|
yuD = snd . dY
|
||||||
|
|
||||||
|
|
||||||
-- |The X offset to move coordinates to the right
|
|
||||||
-- position depending on the X dimensions.
|
|
||||||
xOffset :: DiagProp -> Double
|
|
||||||
xOffset p = (negate (xlD p) / 2) - (xuD p / 2)
|
|
||||||
|
|
||||||
|
|
||||||
-- |The Y offset to move coordinates to the right
|
|
||||||
-- position depending on the X dimensions.
|
|
||||||
yOffset :: DiagProp -> Double
|
|
||||||
yOffset p = (negate (ylD p) / 2) - (yuD p / 2)
|
|
||||||
|
|
||||||
|
|
||||||
-- |Creates a Diagram that shows the coordinates from the VTable
|
-- |Creates a Diagram that shows the coordinates from the VTable
|
||||||
-- as dots. The VTable and thickness of the dots can be controlled
|
-- as dots. The VTable and thickness of the dots can be controlled
|
||||||
@ -97,7 +86,7 @@ showCoordinates = Diag f
|
|||||||
where
|
where
|
||||||
f p vt
|
f p vt
|
||||||
= position (zip (filter (inRange (dX p) (dY p)) $ vt)
|
= position (zip (filter (inRange (dX p) (dY p)) $ vt)
|
||||||
(repeat dot)) # moveTo (p2(xOffset p, yOffset p))
|
(repeat dot))
|
||||||
where
|
where
|
||||||
-- a dot itself is a diagram
|
-- a dot itself is a diagram
|
||||||
dot = (circle $ t p :: Diagram Cairo R2) # fc black
|
dot = (circle $ t p :: Diagram Cairo R2) # fc black
|
||||||
@ -109,7 +98,7 @@ showConvexHullPoints = Diag f
|
|||||||
where
|
where
|
||||||
f p vt
|
f p vt
|
||||||
= position (zip (filter (inRange (dX p) (dY p)) $ vtch)
|
= position (zip (filter (inRange (dX p) (dY p)) $ vtch)
|
||||||
(repeat dot)) # moveTo (p2(xOffset p, yOffset p))
|
(repeat dot))
|
||||||
where
|
where
|
||||||
-- a dot itself is a diagram
|
-- a dot itself is a diagram
|
||||||
dot = (circle $ t p :: Diagram Cairo R2) # fc red # lc red
|
dot = (circle $ t p :: Diagram Cairo R2) # fc red # lc red
|
||||||
@ -121,7 +110,7 @@ showConvexHullPoints = Diag f
|
|||||||
showXAxis :: Diag
|
showXAxis :: Diag
|
||||||
showXAxis = Diag f
|
showXAxis = Diag f
|
||||||
where
|
where
|
||||||
f p _ = hrule (xuD p - xlD p) # moveTo (p2(0, yOffset p))
|
f p _ = (strokeTrail . fromVertices $ [p2 (xlD p,0), p2 (xuD p, 0)]) # moveTo (p2 (xlD p,0))
|
||||||
|
|
||||||
|
|
||||||
-- |Creates a Diagram that shows an YAxis which is bound
|
-- |Creates a Diagram that shows an YAxis which is bound
|
||||||
@ -129,7 +118,7 @@ showXAxis = Diag f
|
|||||||
showYAxis :: Diag
|
showYAxis :: Diag
|
||||||
showYAxis = Diag f
|
showYAxis = Diag f
|
||||||
where
|
where
|
||||||
f p _ = vrule (yuD p - ylD p) # moveTo (p2(xOffset p, 0))
|
f p _ = strokeTrail . fromVertices $ [p2 (0, ylD p), p2 (0, yuD p)] # moveTo (p2 (0, ylD p))
|
||||||
|
|
||||||
|
|
||||||
-- |Creates a Diagram that shows a white rectangle which is a little
|
-- |Creates a Diagram that shows a white rectangle which is a little
|
||||||
@ -137,7 +126,10 @@ showYAxis = Diag f
|
|||||||
showWhiteRectB :: Diag
|
showWhiteRectB :: Diag
|
||||||
showWhiteRectB = Diag f
|
showWhiteRectB = Diag f
|
||||||
where
|
where
|
||||||
f p _ = whiteRect (xuD p - xlD p + 50) (yuD p - ylD p + 50)
|
f p _ = whiteRect (w' + 50) (h' + 50) # moveTo (p2 (w' / 2, h' / 2))
|
||||||
|
where
|
||||||
|
w' = xuD p - xlD p
|
||||||
|
h' = yuD p - ylD p
|
||||||
|
|
||||||
|
|
||||||
-- |Create the Diagram from the VTable.
|
-- |Create the Diagram from the VTable.
|
||||||
@ -157,9 +149,9 @@ diag p = case alg p of
|
|||||||
-- of an obj file.
|
-- of an obj file.
|
||||||
diagS :: DiagProp -> String -> Diagram Cairo R2
|
diagS :: DiagProp -> String -> Diagram Cairo R2
|
||||||
diagS p mesh
|
diagS p mesh
|
||||||
= diag p .
|
= (diag p .
|
||||||
meshToArr $
|
meshToArr $
|
||||||
mesh
|
mesh) # bg white
|
||||||
|
|
||||||
|
|
||||||
-- |Create a white rectangle with the given width and height.
|
-- |Create a white rectangle with the given width and height.
|
||||||
|
36
Gtk.hs
36
Gtk.hs
@ -192,9 +192,7 @@ drawDiag' fp mygui =
|
|||||||
ylD' <- entryGetText (yl mygui)
|
ylD' <- entryGetText (yl mygui)
|
||||||
yuD' <- entryGetText (yu mygui)
|
yuD' <- entryGetText (yu mygui)
|
||||||
alg' <- comboBoxGetActive (cB mygui)
|
alg' <- comboBoxGetActive (cB mygui)
|
||||||
|
(daW, daH) <- widgetGetSize (da mygui)
|
||||||
-- clear drawing area
|
|
||||||
clearDiag mygui
|
|
||||||
|
|
||||||
let xD = (,) <$> readMaybe xlD' <*> readMaybe xuD' :: Maybe (Double,
|
let xD = (,) <$> readMaybe xlD' <*> readMaybe xuD' :: Maybe (Double,
|
||||||
Double)
|
Double)
|
||||||
@ -203,12 +201,14 @@ drawDiag' fp mygui =
|
|||||||
case (xD, yD) of
|
case (xD, yD) of
|
||||||
(Just xD', Just yD') -> do
|
(Just xD', Just yD') -> do
|
||||||
let (_, r) = renderDia Cairo
|
let (_, r) = renderDia Cairo
|
||||||
(CairoOptions "" (Width 600) SVG False)
|
(CairoOptions ""
|
||||||
|
(Dims (fromIntegral daW) (fromIntegral daH))
|
||||||
|
SVG False)
|
||||||
(diagS (def{t = scaleVal,
|
(diagS (def{t = scaleVal,
|
||||||
dX = xD',
|
dX = xD',
|
||||||
dY = yD',
|
dY = yD',
|
||||||
alg = alg'})
|
alg = alg'})
|
||||||
mesh)
|
mesh)
|
||||||
renderWithDrawable dw r
|
renderWithDrawable dw r
|
||||||
return 0
|
return 0
|
||||||
_ -> return 1
|
_ -> return 1
|
||||||
@ -226,11 +226,12 @@ saveDiag' fp mygui =
|
|||||||
mesh <- readFile fp
|
mesh <- readFile fp
|
||||||
adjustment <- rangeGetAdjustment (hs mygui)
|
adjustment <- rangeGetAdjustment (hs mygui)
|
||||||
scaleVal <- adjustmentGetValue adjustment
|
scaleVal <- adjustmentGetValue adjustment
|
||||||
xlD' <- entryGetText (xl mygui)
|
xlD' <- entryGetText (xl mygui)
|
||||||
xuD' <- entryGetText (xu mygui)
|
xuD' <- entryGetText (xu mygui)
|
||||||
ylD' <- entryGetText (yl mygui)
|
ylD' <- entryGetText (yl mygui)
|
||||||
yuD' <- entryGetText (yu mygui)
|
yuD' <- entryGetText (yu mygui)
|
||||||
alg' <- comboBoxGetActive (cB mygui)
|
alg' <- comboBoxGetActive (cB mygui)
|
||||||
|
(daW, daH) <- widgetGetSize (da mygui)
|
||||||
|
|
||||||
let xD = (,) <$> readMaybe xlD' <*> readMaybe xuD' :: Maybe (Double,
|
let xD = (,) <$> readMaybe xlD' <*> readMaybe xuD' :: Maybe (Double,
|
||||||
Double)
|
Double)
|
||||||
@ -238,25 +239,14 @@ saveDiag' fp mygui =
|
|||||||
Double)
|
Double)
|
||||||
case (xD, yD) of
|
case (xD, yD) of
|
||||||
(Just xD', Just yD') -> do
|
(Just xD', Just yD') -> do
|
||||||
renderCairo "out.svg" (Width 600)
|
renderCairo "out.svg"
|
||||||
|
(Dims (fromIntegral daW) (fromIntegral daH))
|
||||||
(diagS (def{t = scaleVal,
|
(diagS (def{t = scaleVal,
|
||||||
dX = xD',
|
dX = xD',
|
||||||
dY = yD',
|
dY = yD',
|
||||||
alg = alg'})
|
alg = alg'})
|
||||||
mesh)
|
mesh)
|
||||||
return 0
|
return 0
|
||||||
_ -> return 1
|
_ -> return 1
|
||||||
|
|
||||||
else return 2
|
else return 2
|
||||||
|
|
||||||
|
|
||||||
-- |Clears the drawing area by painting a white rectangle.
|
|
||||||
clearDiag :: MyGUI
|
|
||||||
-> IO ()
|
|
||||||
clearDiag mygui = do
|
|
||||||
dw <- widgetGetDrawWindow (da mygui)
|
|
||||||
|
|
||||||
let (_, r) = renderDia Cairo
|
|
||||||
(CairoOptions "" (Width 600) SVG False)
|
|
||||||
(whiteRect 600 600)
|
|
||||||
renderWithDrawable dw r
|
|
||||||
|
Loading…
Reference in New Issue
Block a user