Elmでゆる系レイトレーシング

Haskell風言語であり、コンパイルするとJSを出してくれるElmで簡単なレイトレーシングをしてみました。
0.17でだいぶ変わってしまいましたが、使いやすくなったかなーと思います。

実行方法

Elm自体のインストール方法は省きます。npmなりなんなりで入れてあげてください。

以下、コンソール。

$ mkdir ray && cd ray

$ vim Main.elm

$ elm-package install elm-lang/html -y

$ elm-package install evancz/elm-graphics -y

$ cat elm-package.json
{
    "version": "1.0.0",
    "summary": "helpful summary of your project, less than 80 characters",
    "repository": "https://github.com/user/project.git",
    "license": "BSD3",
    "source-directories": [
        "."
    ],
    "exposed-modules": [],
    "dependencies": {
        "elm-lang/core": "4.0.5 <= v < 5.0.0",
        "elm-lang/html": "1.1.0 <= v < 2.0.0",
        "evancz/elm-graphics": "1.0.0 <= v < 2.0.0"
    },
    "elm-version": "0.17.0 <= v < 0.18.0"
}

$ elm reactor
elm reactor 0.17.0
Listening on http://localhost:8000/

（Main.elmは下のコードをコピペしてください。）

elm reactorのあと、ブラウザで http://localhost:8000/Main.elm にアクセスすると、
なんか球っぽいのが表示されると思います。

コード

module Main exposing (main)

import Html.App as App
import Html exposing (div, Html)
import Color

import Element as E
import Collage as C


type alias Vec = { x: Float , y: Float , z: Float }
type alias RGB = { r: Float , g: Float , b: Float }

type alias Sphere = { pos: Vec , rad: Float , color: RGB }
type alias Light = { pos: Vec , color: RGB}
type alias Ray = { dir: Vec , pos: Vec }
type alias Model = { width: Float , height: Float , sphere: Sphere , lights: List Light }

type Msg = Init


init : {width: Float, height: Float} -> (Model, Cmd Msg)
init {width, height} = 
  let 
    sphere = { pos = initV, rad = 1.0, color = white }
    light1 = { pos = {x = 3.0, y = -2.0, z = -2.0}, color = blue }
    light2 = { pos = {x = -3.0, y = 2.0, z = -2.0}, color = red }
    light3 = { pos = {x = 3.0, y = 2.0, z = -2.0}, color = green }
    model =  { width = width , height = height , sphere = sphere , lights = [ light1, light2, light3 ] }
  in (model, Cmd.none)

update : Msg -> Model -> (Model, Cmd a)
update msg model = (model, Cmd.none)

-- 1pxの線で代用
point : Int -> Int -> RGB -> C.Form
point x y c = 
  let mkColor = Color.rgb (round<|c.r*255) (round<|c.g*255) (round<|c.b*255)
  in (C.solid mkColor |> C.traced) 
    <| C.path [(toFloat x, toFloat y), (toFloat <|x+1, toFloat y)] 

view : Model -> Html.Html a
view model = 
  let 
    toInt = round
    ih = toInt model.height
    iw = toInt model.width
  in E.toHtml 
    <| C.collage ((*) 2 <| iw) ((*) 2 <| ih) 
    <| List.concat 
    <| List.map2 (\ y row -> List.map2  (\ x c -> point x y c) [0..iw] row) [0..ih]
    <| scene model 

subscriptions: Model -> Sub a
subscriptions model = Sub.none

main : Program Never
main =  
  App.program { 
      init = (init {width = 800, height = 600})
    , update = update
    , view = view
    , subscriptions = subscriptions
    }

scene : Model -> List (List RGB)
scene model = 
  let 
    ray x y = { 
        dir = normalize { x = x, y = y, z = 5.0 }
      , pos = { x = 0.0, y = 0.0, z = -5.0 }
      }
    way r = (flip (-) <| r / 2) >> flip (/) 100
    listThen = flip List.map
  in 
    [0..model.height-1] `listThen` \y ->
    [0..model.width-1] `listThen` \x -> 
      render model.sphere model.lights <| ray (way model.width x) (way model.height y)

intersect : Sphere -> Ray -> Maybe Float
intersect sph ray = 
  let 
    m = ray.pos `subV` sph.pos
    b = m `dot` ray.dir
    c = b ^ 2 - magnitude2 m + sph.rad ^ 2
    t = -b - sqrt c
  in if c < 0 then Nothing else if t > 0 then Just t else Nothing

render : Sphere -> List Light -> Ray -> RGB
render sphere lights ray = 
  case intersect sphere ray of 
    Just dist -> 
      let 
        diffuse light acc = trace dist sphere light ray |> flip (updateCC (+)) acc
        result = List.foldr diffuse black lights
      in updateC min result 1.0
    Nothing -> black

trace : Float -> Sphere -> Light -> Ray -> RGB
trace dist sphere light ray = 
  let
    r = addV ray.pos <| updateV (*) ray.dir dist
    n = updateV (/) (r `subV` sphere.pos) sphere.rad
    l = light.pos `subV` r |> normalize 
    cos = n `dot` l |> max 0 
  in updateCC (*) sphere.color light.color |> flip (updateC (*)) cos

-- Vec
addV : Vec -> Vec -> Vec
addV = updateVV (+)

subV : Vec -> Vec -> Vec
subV = updateVV (-)

dot : Vec -> Vec -> Float
dot v1 v2 = v1.x * v2.x + v1.y * v2.y + v1.z * v2.z

updateV : (Float-> Float -> Float) -> Vec -> Float -> Vec
updateV f2 vec v = { x = f2 vec.x v , y = f2 vec.y v , z = f2 vec.z v }

updateVV : (Float-> Float -> Float) -> Vec -> Vec -> Vec
updateVV f2 vec1 vec2 = 
  { x = f2 vec1.x vec2.x , y = f2 vec1.y vec2.y , z = f2 vec1.z vec2.z }

initV : Vec
initV = { x = 0.0, y = 0.0, z = 0.0 }

magnitude : Vec -> Float
magnitude {x, y, z}  = sqrt <| x^2 + y^2 + z^2

magnitude2 : Vec -> Float
magnitude2 {x, y, z}  = x^2 + y^2 + z^2

normalize : Vec -> Vec
normalize vec =
  let m = magnitude vec in updateV (/) vec <| if m == 0 then 1 else m

-- Color
updateC : (Float-> Float -> Float) -> RGB -> Float -> RGB
updateC f2 a v = 
  { r = f2 a.r v , g = f2 a.g v , b = f2 a.b v }

updateCC : (Float -> Float -> Float) -> RGB -> RGB -> RGB
updateCC f2 a b = 
  { r = f2 a.r b.r , g = f2 a.g b.g , b = f2 a.b b.b }

addC = updateCC (+)

black = { r = 0.0, g = 0.0, b = 0.0 }
white = { r = 1.0, g = 1.0, b = 1.0 }
red = { r = 1.0, g = 0.0, b = 0.0 }
green = { r = 0.0, g = 1.0, b = 0.0 }
blue = { r = 0.0, g = 0.0, b = 1.0 }

まとめ

コンパイラに怒られましょう。