Contours.hs

import Codec.Picture
import qualified Diagrams.Prelude as Dia
import Diagrams.Prelude ((^&))
import qualified Diagrams.Backend.Cairo as Dia

type ℝ = Double

horizContourLine ::
     ((ℝ,ℝ) -> ℝ) -- ^ The topography/height function
  -> (ℝ,ℝ)        -- ^ x-interval on which to render the path
  -> ℝ            -- ^ Step size / resolution along the path
  -> ℝ            -- ^ Base-level y-coordinate of the line
  -> [(ℝ,ℝ)]      -- ^ Trail line
horizContourLine h (x₀,xe) δx y₀ = go (x₀,y₀)
 where go (x,y) = (x,yTgt)
            : if x<xe then go (x+δx, yTgt) 
                      else []
        where yTgt = y₀ + h (x,y)

imageAsFunction :: Image Pixel8 -> (ℝ,ℝ) -> ℝ
imageAsFunction img (x,y)
  | x>0, x<w, y>0, y<h
               = fromIntegral $ pixelAt img (floor x) (floor $ h-y)
  | otherwise  = 0
 where (w,h) = imgDims img

imageContours :: Image Pixel8  -- ^ Original height-map
              -> ℝ             -- ^ Line spacing
              -> ℝ             -- ^ Amplitude, how bent the lines should get
              -> [[(ℝ,ℝ)]]     -- ^ Resulting contour lines
imageContours img δy η
        = [ horizContourLine ((*η) . imageAsFunction img)
                             (0, w)
                             (δy/3)
                             y₀
          | y₀ <- [0, δy .. h] ]
 where (w,h) = imgDims img

main :: IO ()
main = do
   Right (ImageY8 pear) <- readImage "pear-heightmap.png"
   let (w,h) = imgDims pear
   Dia.renderCairo "pear-relief.png" (Dia.dims $ w^&h)
     $ mconcat
        [ Dia.fromVertices [x^&y | (x,y) <- contour]
        | contour <- imageContours pear 4 0.1 ]

imgDims :: Image a -> (ℝ,ℝ)
imgDims (Image w h _) = (fromIntegral w, fromIntegral h)

pear-heightmap.png