Tape winding

Main.hs

module Main where

import Data.List

import Codec.Picture
import qualified Data.Vector as V

r0             = 50     -- Core thickness
rEnd           = 200    -- Tape role end thickness (no effect?)
thick          = 1      -- Thickness of one sheet of tape
repeatInterval = 30     -- Pattern repeat-distance
sampleInterval = 0.01   -- For numerical integration


------------------------------------------------------------------------------
scan_integrate :: (Float -> Float) -> Float -> Float -> Float -> Float
                  -> (V.Vector Float, V.Vector Float)
scan_integrate f x0 xEnd dx y0 =
  let xs = V.fromList [x0, x0+dx .. xEnd]
      ys = V.scanl (\yAcc x -> yAcc + f x * dx) y0 xs
  in (xs,ys)

interpFloor :: (V.Vector Float, V.Vector Float) -> Float -> Float
interpFloor (xs,ys) x
  | x < xs V.! 0  = ys V.! 0
  | x > V.last xs = V.last ys
  | otherwise = let dx = xs V.! 1 - xs V.! 0
                in  ys V.! floor ((x - V.head xs) / dx)


-- Some helpers from
-- http://www.intmath.com/applications-integration/
--      12-arc-length-curve-parametric-polar.php :
-- r = r0 + (thick/2pi)*theta
-- dr/dtheta = thick/2pi
-- L = integral from 0 to theta of sqrt( r^2 + (dr/dtheta)^2 ) dtheta

main = savePngImage "test.png" (ImageRGBA8 mkPic)

mkPic2 :: Image PixelRGBA8
mkPic2 = generateImage f 400 400
  where
    f x y = lColor (realToFrac x)

mkPic :: Image PixelRGBA8
mkPic = -- Magic numbers size & center the picture
  generateImage f (800 :: Int) (800 :: Int)  
  where (xs,ls) = l
        r x y = sqrt ((x - 400)^2 + (y-400)^2)
        nTurns x y = realToFrac $ floor ( (r x y - r0) / thick )
        extraTh x y = atan2 (y-200) (x-200)
        totalTh x y = nTurns x y + extraTh x y
        f x y = lColor $
                interpFloor (xs,ls) (totalTh (realToFrac x)  (realToFrac y))


-- Function to integrate to get length of tape used in wrapping th radians
f :: Float -> Float
f th = sqrt (
  ((r0 + thick*th/(2*pi))^(2::Int)) +
   (thick/(2*pi))^(2::Int) )

-- Memoize the integral of f above
-- (stored in a length vector indexed by a radians vector - ugly)
l :: (V.Vector Float, V.Vector Float)
l = scan_integrate f 0 ( (rEnd-r0) * 2 *pi / thick ) sampleInterval 0

-- Radius of tape roll vs. radians of tape wound
r :: Float -> Float
r th = r0 + (thick/(2*pi))*th

-- x and y coordinates of tape point after winding th radians (unused)
xy :: Float -> (Float,Float)
xy th = (cos (r th), sin (r th))

------------------------------------------------------------------------------
-- Color pattern on flat tape (yellow & black alternating stripes
lColor :: Float -> PixelRGBA8
lColor len =
  let nCycles = (floor $ len/repeatInterval :: Int)
      theMod = len - realToFrac nCycles * repeatInterval
  in if theMod > repeatInterval/2
     then PixelRGBA8 255 255 0 255
     else PixelRGBA8 0 0 0   255