import Data.Semigroup
data List a = Node (List a) a (List a) | Nil
instance Show a => Show (List a) where
show ls = "[" <> pretty ls <> "]"
pretty :: Show a => List a -> String
pretty Nil = ""
pretty (Node _ a Nil) = show a
pretty (Node _ a ls) = (show a) <> "," <> pretty ls
singleton :: a -> List a
singleton a = Node Nil a Nil
append :: List a -> a -> List a
append (Node p x Nil) a =
let parent = Node p x child
child = Node parent a Nil
in parent
append (Node p x l) a = Node p x (append l a)
join :: List a -> List a -> List a
join l Nil = l
join Nil l = l
join (Node a b Nil) (Node Nil y z) =
let p = Node a b c
c = Node p y z
in p
join (Node a b c) n@(Node Nil _ _) = Node a b $ join c n
join n@(Node _ _ Nil) (Node a b c) = join n a
instance Semigroup (List a) where
(<>) = join
instance Monoid (List a) where
mempty = Nil
mappend = (<>)
fromList :: [a] -> List a
fromList [] = mempty
fromList (x:xs) = (singleton x) <> (fromList xs)
main = do
let x = append (singleton 1) 2
print x
let y = append (singleton 3) 4
let z = x <> y
let w = fromList [5,6,7,8]
print $ z <> w
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
import CodeWorld hiding (Point)
import Data.Set (Set)
import qualified Data.Set as S
import Data.Text (pack)
main = activityOf (initial :: Object) update draw
class Stateful s where
initial :: s
update :: Event -> s -> s
class Drawable d where
draw :: d -> Picture
type Point = (Double, Double, Double)
type Vertex = (Point, Point)
point :: Double -> Double -> Double -> Point
point x y z = (x,y,z)
vertex :: Point -> Point -> Vertex
vertex p q = (p,q)
data Object = Object
{ pos :: Point
, rot :: (Double, Double, Double)
, shape :: Set Vertex
}
instance Stateful Object where
initial = Object (0,0,0) (0,0,0) $ S.fromList
[ vertex (point 5 5 (-5)) (point 5 5 5)
, vertex (point 5 (-5) (-5)) (point 5 5 (-5))
, vertex (point 5 (-5) 5) (point 5 5 5)
, vertex (point 5 (-5) (-5)) (point 5 (-5) 5)
, vertex (point 5 (-5) (-5)) (point (-5) (-5) (-5))
, vertex (point 5 (-5) 5) (point (-5) (-5) 5)
, vertex (point (-5) (-5) (-5)) (point (-5) (-5) 5)
, vertex (point (-5) (-5) (-5)) (point (-5) 5 (-5))
, vertex (point (-5) (-5) 5) (point (-5) 5 5)
, vertex (point (-5) 5 (-5)) (point (-5) 5 5)
, vertex (point (-5) 5 (-5)) (point 5 5 (-5))
, vertex (point (-5) 5 5) (point 5 5 5)
]
update (KeyPress "W") o = o {pos = pos'}
where
pos' = (\(x,y,z) -> (x,y,z+1)) $ pos o
update (KeyPress "S") o = o {pos = pos'}
where
pos' = (\(x,y,z) -> (x,y,z-1)) $ pos o
update (PointerMovement (mx,my)) o = o {pos = (mx,my,z)}
where z = (\(_,_,z) -> z) $ pos o
update (TimePassing dt) o = o --{rot = rot'}
where
(rx,ry,rz) = rot o
rot' = (rx,ry,rz+dt) --rotations dont work too well
update _ o = o
offset :: Point -> Vertex -> Vertex
offset (x0,y0,z0) ((x1,y1,z1),(x2,y2,z2)) = ((x1+x0,y1+y0,z1+z0),(x2+x0,y2+y0,z2+z0))
instance Drawable Object where --TODO: Figure out how to do rotations properly
draw o = mappend
(translated 0 (-9.2) $ dilated 0.6 $ lettering $ pack $ show $ pos o)
$ mappend (drawPoint $ pos o) $ foldMap draw $ S.map ({-rotateVertex (pos o) (rot o) .-} offset (pos o)) $ shape o
drawPoint :: Point -> Picture
drawPoint = (\(x,y) -> translated x y $ solidCircle 0.1) . draw3d
rotateVertex :: Point -> (Double,Double,Double) -> Vertex -> Vertex
rotateVertex o r (p1,p2) = (rotate o p1 r, rotate o p2 r)
rotate :: () --not working properly
=> Point -- point around which to rotate
-> Point -- point to rotate
-> (Double, Double, Double) -- rotations
-> Point
rotate (ox,oy,oz) (x,y,z) (rx,ry,rz) = (nx+ox,ny+oy,nz+oz)
where
(vx,vy,vz) = (x-ox,y-oy,z-oz)
nx = a*e*x + (b*p+a*f*r)*y + (b*q+a*f*s)*z
ny = c*e*x + (d*p+c*f*r)*y + (d*q+c*f*s)*z
nz = g*x+h*r*y+h*s*z
a = cos rz
c = sin rz
b = -c
d = a
e = cos ry
f = sin ry
g = -f
h = e
p = cos rx
q = -r
r = sin rx
s = p
draw3d :: Point -> (Double,Double)
draw3d (x,y,z) = p
where
--z = oz+20
--o = if z /= 0 then 10/z else 100
o = if z > 10 || z < (-10) then signum z else z/10
p = (x-x*o,y-y*o)
instance Drawable Vertex where
draw (p1,p2) = polyline [draw3d p1,draw3d p2]
