Drezil/pioneers
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Compare commits

base: Drezil:gh-pages
Branches Tags
Drezil:master
Drezil:tessallation
Drezil:gh-pages
..
compare: Drezil:master
Branches Tags
Drezil:tessallation
Drezil:master
Drezil:gh-pages

No commits in common. "gh-pages" and "master" have entirely different histories.
gh-pages ... master

66 changed files with 5048 additions and 859 deletions
Show Stats Expand all files Collapse all files

11
.gitignore vendored Normal file
View File

@ -0,0 +1,11 @@
/.dist-buildwrapper
/.project
/.settings
.cabal-sandbox
*.trace
cabal.sandbox.config
deps/hsSDL2*
deps/*.deb
dist/*
*.swp

4
.travis.prepare.sh Executable file
View File

@ -0,0 +1,4 @@
#!/bin/bash
cd deps
./getDeps.sh ni #non-interactively..
cd ..

2
.travis.yml Normal file
View File

@ -0,0 +1,2 @@
language: haskell
before_install: sh .travis.prepare.sh

30
COMPILING Normal file
View File

@ -0,0 +1,30 @@
# on ubuntu14.04 (trusty) and later
just run
> ./build.sh
# manual installation
set up external dependencies:
> sudo apt-get install libsdl2-dev libsdl2-ttf-dev libsdl2-image-dev libsdl2-mixer-dev
> cd deps && ./getDeps.sh && cd ..
NOTE: ubuntu saucy currently only has libsdl2-dev.2.0.0 in the repositories, but we need libsdl2-dev.2.0.1
Therefore the update-script gets the updated packages for trusty (which have the same dependencies)
and installs them.
PIONEERS WONT RUN WITH VERSION 2.0.0 OF LIBSDL2!
make sure the compiled files are in your PATH (e.g. include $HOME/.cabal/bin in your $PATH)
install dependencies & configure app
> cabal sandbox init
> cabal sandbox add-source deps/hsSDL2
> cabal sandbox add-source deps/hsSDL2-ttf
> cabal install --only-dependencies
> cabal configure
build
> cabal build
run ./Pioneers (symlinked to dist/build/Pioneers/Pioneers)

1
Pioneers Symbolic link
View File

@ -0,0 +1 @@
dist/build/Pioneers/Pioneers

81
Pioneers.cabal Normal file
View File

@ -0,0 +1,81 @@
name: Pioneers
version: 0.1
cabal-version: >= 1.16
build-type: Simple
author: sdressel
executable Pioneers
hs-source-dirs: src
if os(windows) {
ghc-options: -Wall -Odph -rtsopts -threaded -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 -optlo-O3
} else {
ghc-options: -Wall -Odph -rtsopts -threaded -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 -optlo-O3 -fllvm
}
other-modules:
Map.Map,
Map.Types,
Map.Graphics,
Map.Creation,
Importer.IQM.Types,
Importer.IQM.Parser,
Render.Misc,
Render.Render,
Render.RenderObject,
Render.Types,
UI.Callbacks,
Types
main-is: Main.hs
build-depends:
base >=4.6,
OpenGL >=2.9,
bytestring >=0.10,
OpenGLRaw >=1.4,
text >=0.11,
array >=0.4,
random >=1.0.1,
transformers >=0.3.0,
unordered-containers >= 0.2.1,
hashable >= 1.0.1.1,
mtl >=2.1.2,
stm >=2.4.2,
vector >=0.10.9 && <0.11,
distributive >=0.3.2,
linear >=1.3.1,
lens >=4.0,
SDL2 >= 0.1.0,
time >=1.4.0,
GLUtil >= 0.7,
attoparsec >= 0.11.2,
attoparsec-binary >= 0.1
Default-Language: Haskell2010
test-suite MapTests
type: exitcode-stdio-1.0
hs-source-dirs: tests/Map, src
main-is: MapTestSuite.hs
build-depends: base,
OpenGL >=2.9,
bytestring >=0.10,
OpenGLRaw >=1.4,
text >=0.11,
array >=0.4,
random >=1.0.1,
transformers >=0.3.0,
unordered-containers >= 0.2.1,
hashable >= 1.0.1.1,
mtl >=2.1.2,
stm >=2.4.2,
vector >=0.10.9 && <0.11,
distributive >=0.3.2,
linear >=1.3.1,
lens >=4.0,
SDL2 >= 0.1.0,
time >=1.4.0,
GLUtil >= 0.7,
attoparsec >= 0.11.2,
attoparsec-binary >= 0.1,
QuickCheck,
test-framework,
test-framework-th,
test-framework-quickcheck2
Default-Language: Haskell2010

30
README.md Normal file
View File

@ -0,0 +1,30 @@
# Pioneers
A Settlers II inspired game written in Haskell
## Development-Status
Bugtracker/Wiki: http://redmine.pwning.de/projects/pioneers
## Compiling
1. Clone this repository
2. install libraries `sudo apt-get install libsdl2 libsdl2-dev libghc-llvm-dev` - make sure libsdl2 is in version 2.0.1+ (shipped with Ubuntu since 14.04)
3. run `./build.sh`
4. run `./Pioneers`
The script sets up a cabal sandbox, downloads some libraries and compiles them. Only tested under Ubuntu 14.04. Won't work with Ubuntu < 14.04 due to lacking libraries (libsdl2)
## Features
Note, that most of it is just planned and due to change.
- modern OpenGL3.x-Engine
- themeable with different Cultures
- rock-solid Multiplayer (no desync, just slightly more lag in case of resync)
## Why Haskell?
- There are not enough good games written in functional languages.
- More robust and easier to reason about lateron

2
Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

12
build.sh Executable file
View File

@ -0,0 +1,12 @@
#!/bin/bash
cabal sandbox init
cd deps
./getDeps.sh
cd ..
cabal sandbox add-source deps/hsSDL2
cabal sandbox add-source deps/hsSDL2-ttf
cabal install --only-dependencies
cabal configure
cabal build

84
deps/getDeps.sh vendored Executable file
View File

@ -0,0 +1,84 @@
#!/bin/bash
if [ "$1" != "ni" ]
then
if [ ! -f /usr/bin/dialog ]
then
sudo apt-get install dialog
fi
dialog --yesno "Install libSDL2 from ubuntu trusty repositories?\n\nSAUCY IS NOT SUPPORTED! You NEED Ubuntu 14.04+\n\nThe script will try to install the trusty-packages." 20 75
install=${?}
else
install=0
fi
if [[ $install -eq 0 ]]
then
sudo apt-get install libsdl2-dev libsdl2-ttf-dev libsdl2-image-dev libsdl2-mixer-dev
fi
echo "cloning repositories"
if [ ! -d "hsSDL2" ]
then
git clone https://github.com/Lemmih/hsSDL2 hsSDL2
else
cd hsSDL2
git pull
cd ..
fi
if [ ! -d "hsSDL2-ttf" ]
then
git clone https://github.com/osa1/hsSDL2-ttf hsSDL2-ttf
else
cd hsSDL2-ttf
git pull
cd ..
fi
if [ ! -d "hsSDL2-mixer" ]
then
git clone https://github.com/jdeseno/hs-sdl2-mixer hsSDL2-mixer
else
cd hsSDL2-mixer
git pull
cd ..
fi
if [ ! -d "hsSDL2-image" ]
then
git clone https://github.com/jdeseno/hs-sdl2-image hsSDL2-image
else
cd hsSDL2-image
git pull
cd ..
fi
echo "trying to build"
cabal install haddock
echo "building hsSDL2.."
cd hsSDL2
cabal sandbox delete
cabal sandbox init
cabal install --only-dependencies
cabal build
cd ..
for t in "hsSDL2-ttf" "hsSDL2-mixer" "hsSDL2-image"
do
echo "building ${t}.."
cd "${t}"
cabal sandbox delete
cabal sandbox init
cabal sandbox add-source ../hsSDL2
cabal install --only-dependencies
cabal build
cd ..
done

BIN
design/Map-Entwurf.xcf Normal file
View File

Binary file not shown.

BIN
design/Map-Entwurf1.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 56 KiB

BIN
design/Map-Entwurf2.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 25 KiB

1
fonts/install_fonts.sh Normal file
View File

@ -0,0 +1 @@
sudo cp * /usr/share/fonts/truetype/

BIN
fonts/ttf-04B_03B_/04B_03B_.TTF Normal file
View File

Binary file not shown.

BIN
fonts/ttf-04B_03B_/about.gif Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 2.7 KiB

BIN
images/body-bg.jpg
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 3.1 KiB

BIN
images/download-button.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 31 KiB

BIN
images/github-button.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 3.1 KiB

BIN
images/header-bg.jpg
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 10 KiB

BIN
images/highlight-bg.jpg
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 33 KiB

BIN
images/sidebar-bg.jpg
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 3.1 KiB

83
index.html
View File

@ -1,83 +0,0 @@
<!DOCTYPE html>
<html>
<head>
<meta charset='utf-8'>
<meta http-equiv="X-UA-Compatible" content="chrome=1">
<meta name="viewport" content="width=device-width, initial-scale=1, maximum-scale=1">
<link href='https://fonts.googleapis.com/css?family=Architects+Daughter' rel='stylesheet' type='text/css'>
<link rel="stylesheet" type="text/css" href="stylesheets/stylesheet.css" media="screen" />
<link rel="stylesheet" type="text/css" href="stylesheets/pygment_trac.css" media="screen" />
<link rel="stylesheet" type="text/css" href="stylesheets/print.css" media="print" />
<!--[if lt IE 9]>
<script src="//html5shiv.googlecode.com/svn/trunk/html5.js"></script>
<![endif]-->
<title>Pioneers by Drezil</title>
</head>
<body>
<header>
<div class="inner">
<h1>Pioneers</h1>
<h2>Strategy-Game in Haskell similar to &quot;Settlers II&quot;</h2>
<a href="https://github.com/Drezil/pioneers" class="button"><small>View project on</small>GitHub</a>
</div>
</header>
<div id="content-wrapper">
<div class="inner clearfix">
<section id="main-content">
<h3>
<a name="welcome-to-github-pages" class="anchor" href="#welcome-to-github-pages"><span class="octicon octicon-link"></span></a>Welcome to GitHub Pages.</h3>
<p>This automatic page generator is the easiest way to create beautiful pages for all of your projects. Author your page content here using GitHub Flavored Markdown, select a template crafted by a designer, and publish. After your page is generated, you can check out the new branch:</p>
<pre><code>$ cd your_repo_root/repo_name
$ git fetch origin
$ git checkout gh-pages
</code></pre>
<p>If you're using the GitHub for Mac, simply sync your repository and you'll see the new branch.</p>
<h3>
<a name="designer-templates" class="anchor" href="#designer-templates"><span class="octicon octicon-link"></span></a>Designer Templates</h3>
<p>We've crafted some handsome templates for you to use. Go ahead and continue to layouts to browse through them. You can easily go back to edit your page before publishing. After publishing your page, you can revisit the page generator and switch to another theme. Your Page content will be preserved if it remained markdown format.</p>
<h3>
<a name="rather-drive-stick" class="anchor" href="#rather-drive-stick"><span class="octicon octicon-link"></span></a>Rather Drive Stick?</h3>
<p>If you prefer to not use the automatic generator, push a branch named <code>gh-pages</code> to your repository to create a page manually. In addition to supporting regular HTML content, GitHub Pages support Jekyll, a simple, blog aware static site generator written by our own Tom Preston-Werner. Jekyll makes it easy to create site-wide headers and footers without having to copy them across every page. It also offers intelligent blog support and other advanced templating features.</p>
<h3>
<a name="authors-and-contributors" class="anchor" href="#authors-and-contributors"><span class="octicon octicon-link"></span></a>Authors and Contributors</h3>
<p>You can <a href="https://github.com/blog/821" class="user-mention">@mention</a> a GitHub username to generate a link to their profile. The resulting <code>&lt;a&gt;</code> element will link to the contributor's GitHub Profile. For example: In 2007, Chris Wanstrath (<a href="https://github.com/defunkt" class="user-mention">@defunkt</a>), PJ Hyett (<a href="https://github.com/pjhyett" class="user-mention">@pjhyett</a>), and Tom Preston-Werner (<a href="https://github.com/mojombo" class="user-mention">@mojombo</a>) founded GitHub.</p>
<h3>
<a name="support-or-contact" class="anchor" href="#support-or-contact"><span class="octicon octicon-link"></span></a>Support or Contact</h3>
<p>Having trouble with Pages? Check out the documentation at <a href="http://help.github.com/pages">http://help.github.com/pages</a> or contact <a href="mailto:support@github.com">support@github.com</a> and we’ll help you sort it out.</p>
</section>
<aside id="sidebar">
<a href="https://github.com/Drezil/pioneers/zipball/master" class="button">
<small>Download</small>
.zip file
</a>
<a href="https://github.com/Drezil/pioneers/tarball/master" class="button">
<small>Download</small>
.tar.gz file
</a>
<p class="repo-owner"><a href="https://github.com/Drezil/pioneers"></a> is maintained by <a href="https://github.com/Drezil">Drezil</a>.</p>
<p>This page was generated by <a href="https://pages.github.com">GitHub Pages</a> using the Architect theme by <a href="https://twitter.com/jasonlong">Jason Long</a>.</p>
</aside>
</div>
</div>
</body>
</html>

1
javascripts/main.js
View File

@ -1 +0,0 @@
console.log('This would be the main JS file.');

BIN
models/box.blend Normal file
View File

Binary file not shown.

118
models/box.iqe Normal file
View File

@ -0,0 +1,118 @@
# Inter-Quake Export
joint "Bone" -1
pq 0.00000000 0.00000000 0.00000000 -0.70710683 -0.00000000 -0.00000000 -0.70710683
mesh "Cube"
material "Material"
vp 0.50000000 0.49999997 0.00000000
vt 0.00000000 0.00000000
vn 0.00000000 0.00000000 -1.00000000
vb 0 0.99999976
vp -0.50000006 -0.49999991 0.00000000
vt 0.00000000 0.00000000
vn 0.00000000 0.00000000 -1.00000000
vb 0 0.99999994
vp 0.50000000 -0.50000000 0.00000000
vt 0.00000000 0.00000000
vn 0.00000000 0.00000000 -1.00000000
vb 0 0.99999988
vp -0.49999982 0.50000018 0.00000000
vt 0.00000000 0.00000000
vn 0.00000000 0.00000000 -1.00000000
vb 0 0.99999994
vp 0.50000024 0.49999973 1.00000000
vt 0.00000000 0.00000000
vn 0.00000000 0.00000000 1.00000000
vb 0 0.99999976
vp -0.50000018 -0.49999982 1.00000000
vt 0.00000000 0.00000000
vn 0.00000000 0.00000000 1.00000000
vb 0 0.99999994
vp -0.49999997 0.50000000 1.00000000
vt 0.00000000 0.00000000
vn 0.00000000 0.00000000 1.00000000
vb 0 1.00000000
vp 0.49999967 -0.50000030 1.00000000
vt 0.00000000 0.00000000
vn 0.00000000 0.00000000 1.00000000
vb 0 0.99999988
vp 0.50000000 0.49999997 0.00000000
vt 0.00000000 0.00000000
vn 1.00000000 -0.00000028 0.00000004
vb 0 0.99999976
vp 0.49999967 -0.50000030 1.00000000
vt 0.00000000 0.00000000
vn 1.00000000 -0.00000028 0.00000004
vb 0 0.99999988
vp 0.50000024 0.49999973 1.00000000
vt 0.00000000 0.00000000
vn 1.00000000 -0.00000028 0.00000004
vb 0 0.99999976
vp 0.50000000 -0.50000000 0.00000000
vt 0.00000000 0.00000000
vn 1.00000000 -0.00000028 0.00000004
vb 0 0.99999988
vp 0.50000000 -0.50000000 0.00000000
vt 0.00000000 0.00000000
vn -0.00000028 -1.00000000 -0.00000010
vb 0 0.99999988
vp -0.50000018 -0.49999982 1.00000000
vt 0.00000000 0.00000000
vn -0.00000028 -1.00000000 -0.00000010
vb 0 0.99999994
vp 0.49999967 -0.50000030 1.00000000
vt 0.00000000 0.00000000
vn -0.00000028 -1.00000000 -0.00000010
vb 0 0.99999988
vp -0.50000006 -0.49999991 0.00000000
vt 0.00000000 0.00000000
vn -0.00000028 -1.00000000 -0.00000010
vb 0 0.99999994
vp -0.50000006 -0.49999991 0.00000000
vt 0.00000000 0.00000000
vn -1.00000000 0.00000022 -0.00000013
vb 0 0.99999994
vp -0.49999997 0.50000000 1.00000000
vt 0.00000000 0.00000000
vn -1.00000000 0.00000022 -0.00000013
vb 0 1.00000000
vp -0.50000018 -0.49999982 1.00000000
vt 0.00000000 0.00000000
vn -1.00000000 0.00000022 -0.00000013
vb 0 0.99999994
vp -0.49999982 0.50000018 0.00000000
vt 0.00000000 0.00000000
vn -1.00000000 0.00000022 -0.00000013
vb 0 0.99999994
vp 0.50000024 0.49999973 1.00000000
vt 0.00000000 0.00000000
vn 0.00000024 1.00000000 0.00000021
vb 0 0.99999976
vp -0.49999982 0.50000018 0.00000000
vt 0.00000000 0.00000000
vn 0.00000024 1.00000000 0.00000021
vb 0 0.99999994
vp 0.50000000 0.49999997 0.00000000
vt 0.00000000 0.00000000
vn 0.00000024 1.00000000 0.00000021
vb 0 0.99999976
vp -0.49999997 0.50000000 1.00000000
vt 0.00000000 0.00000000
vn 0.00000024 1.00000000 0.00000021
vb 0 1.00000000
fm 0 1 2
fm 0 3 1
fm 4 5 6
fm 4 7 5
fm 8 9 10
fm 8 11 9
fm 12 13 14
fm 12 15 13
fm 16 17 18
fm 16 19 17
fm 20 21 22
fm 20 23 21

BIN
models/box.iqm Normal file
View File

Binary file not shown.

BIN
models/holzfaellerHaus1.iqm Normal file
View File

Binary file not shown.

1
params.json
View File

@ -1 +0,0 @@
{"name":"Pioneers","tagline":"Strategy-Game in Haskell similar to \"Settlers II\"","body":"### Welcome to GitHub Pages.\r\nThis automatic page generator is the easiest way to create beautiful pages for all of your projects. Author your page content here using GitHub Flavored Markdown, select a template crafted by a designer, and publish. After your page is generated, you can check out the new branch:\r\n\r\n```\r\n$ cd your_repo_root/repo_name\r\n$ git fetch origin\r\n$ git checkout gh-pages\r\n```\r\n\r\nIf you're using the GitHub for Mac, simply sync your repository and you'll see the new branch.\r\n\r\n### Designer Templates\r\nWe've crafted some handsome templates for you to use. Go ahead and continue to layouts to browse through them. You can easily go back to edit your page before publishing. After publishing your page, you can revisit the page generator and switch to another theme. Your Page content will be preserved if it remained markdown format.\r\n\r\n### Rather Drive Stick?\r\nIf you prefer to not use the automatic generator, push a branch named `gh-pages` to your repository to create a page manually. In addition to supporting regular HTML content, GitHub Pages support Jekyll, a simple, blog aware static site generator written by our own Tom Preston-Werner. Jekyll makes it easy to create site-wide headers and footers without having to copy them across every page. It also offers intelligent blog support and other advanced templating features.\r\n\r\n### Authors and Contributors\r\nYou can @mention a GitHub username to generate a link to their profile. The resulting `<a>` element will link to the contributor's GitHub Profile. For example: In 2007, Chris Wanstrath (@defunkt), PJ Hyett (@pjhyett), and Tom Preston-Werner (@mojombo) founded GitHub.\r\n\r\n### Support or Contact\r\nHaving trouble with Pages? Check out the documentation at http://help.github.com/pages or contact support@github.com and we’ll help you sort it out.\r\n","google":"","note":"Don't delete this file! It's used internally to help with page regeneration."}

70
shaders/3rdParty/noise2D.glsl vendored Normal file
View File

@ -0,0 +1,70 @@
//
// Description : Array and textureless GLSL 2D simplex noise function.
// Author : Ian McEwan, Ashima Arts.
// Maintainer : ijm
// Lastmod : 20110822 (ijm)
// License : Copyright (C) 2011 Ashima Arts. All rights reserved.
// Distributed under the MIT License. See LICENSE file.
// https://github.com/ashima/webgl-noise
//
vec3 mod289(vec3 x) {
return x - floor(x * (1.0 / 289.0)) * 289.0;
}
vec2 mod289(vec2 x) {
return x - floor(x * (1.0 / 289.0)) * 289.0;
}
vec3 permute(vec3 x) {
return mod289(((x*34.0)+1.0)*x);
}
float snoise(vec2 v)
{
const vec4 C = vec4(0.211324865405187, // (3.0-sqrt(3.0))/6.0
0.366025403784439, // 0.5*(sqrt(3.0)-1.0)
-0.577350269189626, // -1.0 + 2.0 * C.x
0.024390243902439); // 1.0 / 41.0
// First corner
vec2 i = floor(v + dot(v, C.yy) );
vec2 x0 = v - i + dot(i, C.xx);
// Other corners
vec2 i1;
//i1.x = step( x0.y, x0.x ); // x0.x > x0.y ? 1.0 : 0.0
//i1.y = 1.0 - i1.x;
i1 = (x0.x > x0.y) ? vec2(1.0, 0.0) : vec2(0.0, 1.0);
// x0 = x0 - 0.0 + 0.0 * C.xx ;
// x1 = x0 - i1 + 1.0 * C.xx ;
// x2 = x0 - 1.0 + 2.0 * C.xx ;
vec4 x12 = x0.xyxy + C.xxzz;
x12.xy -= i1;
// Permutations
i = mod289(i); // Avoid truncation effects in permutation
vec3 p = permute( permute( i.y + vec3(0.0, i1.y, 1.0 ))
+ i.x + vec3(0.0, i1.x, 1.0 ));
vec3 m = max(0.5 - vec3(dot(x0,x0), dot(x12.xy,x12.xy), dot(x12.zw,x12.zw)), 0.0);
m = m*m ;
m = m*m ;
// Gradients: 41 points uniformly over a line, mapped onto a diamond.
// The ring size 17*17 = 289 is close to a multiple of 41 (41*7 = 287)
vec3 x = 2.0 * fract(p * C.www) - 1.0;
vec3 h = abs(x) - 0.5;
vec3 ox = floor(x + 0.5);
vec3 a0 = x - ox;
// Normalise gradients implicitly by scaling m
// Approximation of: m *= inversesqrt( a0*a0 + h*h );
m *= 1.79284291400159 - 0.85373472095314 * ( a0*a0 + h*h );
// Compute final noise value at P
vec3 g;
g.x = a0.x * x0.x + h.x * x0.y;
g.yz = a0.yz * x12.xz + h.yz * x12.yw;
return 130.0 * dot(m, g);
}

102
shaders/3rdParty/noise3D.glsl vendored Normal file
View File

@ -0,0 +1,102 @@
//
// Description : Array and textureless GLSL 2D/3D/4D simplex
// noise functions.
// Author : Ian McEwan, Ashima Arts.
// Maintainer : ijm
// Lastmod : 20110822 (ijm)
// License : Copyright (C) 2011 Ashima Arts. All rights reserved.
// Distributed under the MIT License. See LICENSE file.
// https://github.com/ashima/webgl-noise
//
vec3 mod289(vec3 x) {
return x - floor(x * (1.0 / 289.0)) * 289.0;
}
vec4 mod289(vec4 x) {
return x - floor(x * (1.0 / 289.0)) * 289.0;
}
vec4 permute(vec4 x) {
return mod289(((x*34.0)+1.0)*x);
}
vec4 taylorInvSqrt(vec4 r)
{
return 1.79284291400159 - 0.85373472095314 * r;
}
float snoise(vec3 v)
{
const vec2 C = vec2(1.0/6.0, 1.0/3.0) ;
const vec4 D = vec4(0.0, 0.5, 1.0, 2.0);
// First corner
vec3 i = floor(v + dot(v, C.yyy) );
vec3 x0 = v - i + dot(i, C.xxx) ;
// Other corners
vec3 g = step(x0.yzx, x0.xyz);
vec3 l = 1.0 - g;
vec3 i1 = min( g.xyz, l.zxy );
vec3 i2 = max( g.xyz, l.zxy );
// x0 = x0 - 0.0 + 0.0 * C.xxx;
// x1 = x0 - i1 + 1.0 * C.xxx;
// x2 = x0 - i2 + 2.0 * C.xxx;
// x3 = x0 - 1.0 + 3.0 * C.xxx;
vec3 x1 = x0 - i1 + C.xxx;
vec3 x2 = x0 - i2 + C.yyy; // 2.0*C.x = 1/3 = C.y
vec3 x3 = x0 - D.yyy; // -1.0+3.0*C.x = -0.5 = -D.y
// Permutations
i = mod289(i);
vec4 p = permute( permute( permute(
i.z + vec4(0.0, i1.z, i2.z, 1.0 ))
+ i.y + vec4(0.0, i1.y, i2.y, 1.0 ))
+ i.x + vec4(0.0, i1.x, i2.x, 1.0 ));
// Gradients: 7x7 points over a square, mapped onto an octahedron.
// The ring size 17*17 = 289 is close to a multiple of 49 (49*6 = 294)
float n_ = 0.142857142857; // 1.0/7.0
vec3 ns = n_ * D.wyz - D.xzx;
vec4 j = p - 49.0 * floor(p * ns.z * ns.z); // mod(p,7*7)
vec4 x_ = floor(j * ns.z);
vec4 y_ = floor(j - 7.0 * x_ ); // mod(j,N)
vec4 x = x_ *ns.x + ns.yyyy;
vec4 y = y_ *ns.x + ns.yyyy;
vec4 h = 1.0 - abs(x) - abs(y);
vec4 b0 = vec4( x.xy, y.xy );
vec4 b1 = vec4( x.zw, y.zw );
//vec4 s0 = vec4(lessThan(b0,0.0))*2.0 - 1.0;
//vec4 s1 = vec4(lessThan(b1,0.0))*2.0 - 1.0;
vec4 s0 = floor(b0)*2.0 + 1.0;
vec4 s1 = floor(b1)*2.0 + 1.0;
vec4 sh = -step(h, vec4(0.0));
vec4 a0 = b0.xzyw + s0.xzyw*sh.xxyy ;
vec4 a1 = b1.xzyw + s1.xzyw*sh.zzww ;
vec3 p0 = vec3(a0.xy,h.x);
vec3 p1 = vec3(a0.zw,h.y);
vec3 p2 = vec3(a1.xy,h.z);
vec3 p3 = vec3(a1.zw,h.w);
//Normalise gradients
vec4 norm = taylorInvSqrt(vec4(dot(p0,p0), dot(p1,p1), dot(p2, p2), dot(p3,p3)));
p0 *= norm.x;
p1 *= norm.y;
p2 *= norm.z;
p3 *= norm.w;
// Mix final noise value
vec4 m = max(0.6 - vec4(dot(x0,x0), dot(x1,x1), dot(x2,x2), dot(x3,x3)), 0.0);
m = m * m;
return 42.0 * dot( m*m, vec4( dot(p0,x0), dot(p1,x1),
dot(p2,x2), dot(p3,x3) ) );
}

128
shaders/3rdParty/noise4D.glsl vendored Normal file
View File

@ -0,0 +1,128 @@
//
// Description : Array and textureless GLSL 2D/3D/4D simplex
// noise functions.
// Author : Ian McEwan, Ashima Arts.
// Maintainer : ijm
// Lastmod : 20110822 (ijm)
// License : Copyright (C) 2011 Ashima Arts. All rights reserved.
// Distributed under the MIT License. See LICENSE file.
// https://github.com/ashima/webgl-noise
//
vec4 mod289(vec4 x) {
return x - floor(x * (1.0 / 289.0)) * 289.0; }
float mod289(float x) {
return x - floor(x * (1.0 / 289.0)) * 289.0; }
vec4 permute(vec4 x) {
return mod289(((x*34.0)+1.0)*x);
}
float permute(float x) {
return mod289(((x*34.0)+1.0)*x);
}
vec4 taylorInvSqrt(vec4 r)
{
return 1.79284291400159 - 0.85373472095314 * r;
}
float taylorInvSqrt(float r)
{
return 1.79284291400159 - 0.85373472095314 * r;
}
vec4 grad4(float j, vec4 ip)
{
const vec4 ones = vec4(1.0, 1.0, 1.0, -1.0);
vec4 p,s;
p.xyz = floor( fract (vec3(j) * ip.xyz) * 7.0) * ip.z - 1.0;
p.w = 1.5 - dot(abs(p.xyz), ones.xyz);
s = vec4(lessThan(p, vec4(0.0)));
p.xyz = p.xyz + (s.xyz*2.0 - 1.0) * s.www;
return p;
}
// (sqrt(5) - 1)/4 = F4, used once below
#define F4 0.309016994374947451
float snoise(vec4 v)
{
const vec4 C = vec4( 0.138196601125011, // (5 - sqrt(5))/20 G4
0.276393202250021, // 2 * G4
0.414589803375032, // 3 * G4
-0.447213595499958); // -1 + 4 * G4
// First corner
vec4 i = floor(v + dot(v, vec4(F4)) );
vec4 x0 = v - i + dot(i, C.xxxx);
// Other corners
// Rank sorting originally contributed by Bill Licea-Kane, AMD (formerly ATI)
vec4 i0;
vec3 isX = step( x0.yzw, x0.xxx );
vec3 isYZ = step( x0.zww, x0.yyz );
// i0.x = dot( isX, vec3( 1.0 ) );
i0.x = isX.x + isX.y + isX.z;
i0.yzw = 1.0 - isX;
// i0.y += dot( isYZ.xy, vec2( 1.0 ) );
i0.y += isYZ.x + isYZ.y;
i0.zw += 1.0 - isYZ.xy;
i0.z += isYZ.z;
i0.w += 1.0 - isYZ.z;
// i0 now contains the unique values 0,1,2,3 in each channel
vec4 i3 = clamp( i0, 0.0, 1.0 );
vec4 i2 = clamp( i0-1.0, 0.0, 1.0 );
vec4 i1 = clamp( i0-2.0, 0.0, 1.0 );
// x0 = x0 - 0.0 + 0.0 * C.xxxx
// x1 = x0 - i1 + 1.0 * C.xxxx
// x2 = x0 - i2 + 2.0 * C.xxxx
// x3 = x0 - i3 + 3.0 * C.xxxx
// x4 = x0 - 1.0 + 4.0 * C.xxxx
vec4 x1 = x0 - i1 + C.xxxx;
vec4 x2 = x0 - i2 + C.yyyy;
vec4 x3 = x0 - i3 + C.zzzz;
vec4 x4 = x0 + C.wwww;
// Permutations
i = mod289(i);
float j0 = permute( permute( permute( permute(i.w) + i.z) + i.y) + i.x);
vec4 j1 = permute( permute( permute( permute (
i.w + vec4(i1.w, i2.w, i3.w, 1.0 ))
+ i.z + vec4(i1.z, i2.z, i3.z, 1.0 ))
+ i.y + vec4(i1.y, i2.y, i3.y, 1.0 ))
+ i.x + vec4(i1.x, i2.x, i3.x, 1.0 ));
// Gradients: 7x7x6 points over a cube, mapped onto a 4-cross polytope
// 7*7*6 = 294, which is close to the ring size 17*17 = 289.
vec4 ip = vec4(1.0/294.0, 1.0/49.0, 1.0/7.0, 0.0) ;
vec4 p0 = grad4(j0, ip);
vec4 p1 = grad4(j1.x, ip);
vec4 p2 = grad4(j1.y, ip);
vec4 p3 = grad4(j1.z, ip);
vec4 p4 = grad4(j1.w, ip);
// Normalise gradients
vec4 norm = taylorInvSqrt(vec4(dot(p0,p0), dot(p1,p1), dot(p2, p2), dot(p3,p3)));
p0 *= norm.x;
p1 *= norm.y;
p2 *= norm.z;
p3 *= norm.w;
p4 *= taylorInvSqrt(dot(p4,p4));
// Mix contributions from the five corners
vec3 m0 = max(0.6 - vec3(dot(x0,x0), dot(x1,x1), dot(x2,x2)), 0.0);
vec2 m1 = max(0.6 - vec2(dot(x3,x3), dot(x4,x4) ), 0.0);
m0 = m0 * m0;
m1 = m1 * m1;
return 49.0 * ( dot(m0*m0, vec3( dot( p0, x0 ), dot( p1, x1 ), dot( p2, x2 )))
+ dot(m1*m1, vec2( dot( p3, x3 ), dot( p4, x4 ) ) ) ) ;
}

169
shaders/map/fragment.shader Normal file
View File

@ -0,0 +1,169 @@
#version 330
//#include "3rdParty/noise.glsl"
vec3 mod289(vec3 x) {
return x - floor(x * (1.0 / 289.0)) * 289.0;
}
vec4 mod289(vec4 x) {
return x - floor(x * (1.0 / 289.0)) * 289.0;
}
vec4 permute(vec4 x) {
return mod289(((x*34.0)+1.0)*x);
}
vec4 taylorInvSqrt(vec4 r)
{
return 1.79284291400159 - 0.85373472095314 * r;
}
float snoise(vec3 v)
{
const vec2 C = vec2(1.0/6.0, 1.0/3.0) ;
const vec4 D = vec4(0.0, 0.5, 1.0, 2.0);
// First corner
vec3 i = floor(v + dot(v, C.yyy) );
vec3 x0 = v - i + dot(i, C.xxx) ;
// Other corners
vec3 g = step(x0.yzx, x0.xyz);
vec3 l = 1.0 - g;
vec3 i1 = min( g.xyz, l.zxy );
vec3 i2 = max( g.xyz, l.zxy );
// x0 = x0 - 0.0 + 0.0 * C.xxx;
// x1 = x0 - i1 + 1.0 * C.xxx;
// x2 = x0 - i2 + 2.0 * C.xxx;
// x3 = x0 - 1.0 + 3.0 * C.xxx;
vec3 x1 = x0 - i1 + C.xxx;
vec3 x2 = x0 - i2 + C.yyy; // 2.0*C.x = 1/3 = C.y
vec3 x3 = x0 - D.yyy; // -1.0+3.0*C.x = -0.5 = -D.y
// Permutations
i = mod289(i);
vec4 p = permute( permute( permute(
i.z + vec4(0.0, i1.z, i2.z, 1.0 ))
+ i.y + vec4(0.0, i1.y, i2.y, 1.0 ))
+ i.x + vec4(0.0, i1.x, i2.x, 1.0 ));
// Gradients: 7x7 points over a square, mapped onto an octahedron.
// The ring size 17*17 = 289 is close to a multiple of 49 (49*6 = 294)
float n_ = 0.142857142857; // 1.0/7.0
vec3 ns = n_ * D.wyz - D.xzx;
vec4 j = p - 49.0 * floor(p * ns.z * ns.z); // mod(p,7*7)
vec4 x_ = floor(j * ns.z);
vec4 y_ = floor(j - 7.0 * x_ ); // mod(j,N)
vec4 x = x_ *ns.x + ns.yyyy;
vec4 y = y_ *ns.x + ns.yyyy;
vec4 h = 1.0 - abs(x) - abs(y);
vec4 b0 = vec4( x.xy, y.xy );
vec4 b1 = vec4( x.zw, y.zw );
//vec4 s0 = vec4(lessThan(b0,0.0))*2.0 - 1.0;
//vec4 s1 = vec4(lessThan(b1,0.0))*2.0 - 1.0;
vec4 s0 = floor(b0)*2.0 + 1.0;
vec4 s1 = floor(b1)*2.0 + 1.0;
vec4 sh = -step(h, vec4(0.0));
vec4 a0 = b0.xzyw + s0.xzyw*sh.xxyy ;
vec4 a1 = b1.xzyw + s1.xzyw*sh.zzww ;
vec3 p0 = vec3(a0.xy,h.x);
vec3 p1 = vec3(a0.zw,h.y);
vec3 p2 = vec3(a1.xy,h.z);
vec3 p3 = vec3(a1.zw,h.w);
//Normalise gradients
vec4 norm = taylorInvSqrt(vec4(dot(p0,p0), dot(p1,p1), dot(p2, p2), dot(p3,p3)));
p0 *= norm.x;
p1 *= norm.y;
p2 *= norm.z;
p3 *= norm.w;
// Mix final noise value
vec4 m = max(0.6 - vec4(dot(x0,x0), dot(x1,x1), dot(x2,x2), dot(x3,x3)), 0.0);
m = m * m;
return 42.0 * dot( m*m, vec4( dot(p0,x0), dot(p1,x1),
dot(p2,x2), dot(p3,x3) ) );
}
float fog(float dist) {
dist = max(0,dist - 50);
dist = dist * 0.05;
// dist = dist*dist;
return 1-exp(-dist);
}
smooth in vec3 teNormal;
smooth in vec3 tePosition;
smooth in float fogDist;
smooth in float gmix;
in vec4 teColor;
in vec3 tePatchDistance;
out vec4 fgColor;
uniform mat4 ViewMatrix;
uniform mat4 ProjectionMatrix;
void main(void)
{
//fog color
vec4 fogColor = vec4(0.6,0.7,0.8,1.0);
//grid color
vec4 grid = vec4(0.0,0.0,0.0,1.0);
//point color
vec4 point = vec4(1.0,0.9,0.1,1.0);
//heliospheric lighting
vec4 light = vec4(1.0,1.0,1.0,1.0);
vec4 dark = vec4(0.0,0.0,0.0,1.0);
//direction to sun from origin
vec3 lightDir = normalize(ViewMatrix * vec4(5.0,5.0,1.0,0.0)).xyz;
float costheta = dot(teNormal, lightDir);
float a = costheta * 0.5 + 0.5;
//create gravel-texel
vec3 uvw = tePosition;
// Six components of noise in a fractal sum
//float n = snoise(uvw * 10);
float n = 0;
n += 0.5 * snoise(uvw * 20.0);
//n += 0.25 * snoise(uvw * 40.0);
//n += 0.125 * snoise(uvw * 80.0);
//n += 0.0625 * snoise(uvw * 160.0);
//n += 0.03125 * snoise(uvw * 320.0);
n = abs(n*2);//[0,1]
//dirt
float d = snoise(uvw);
d += 0.5 * snoise(uvw * 2);
d += 0.25 * snoise(uvw * 4);
d = d/3*2 +0.5;
// base, dirt, noise-level*(above 0?)*(linear blend by y)
vec4 texBase = mix(teColor, vec4(0.45,0.27,0.1,1),d*d*step(0.01,tePosition.y)*clamp(tePosition.y/2,0,2));
// stone highlights
vec4 texHighlights = mix(texBase, vec4(0.9*n,0.9*n,0.9*n,1),n*n*n);
//mix highlights into Color with inclination, if inclination^2 > 0.35
vec4 texColor = mix(texBase,texHighlights, (gmix*(1-gmix))*4*(gmix*(1-gmix))*4);
vec4 Color = texColor;
fgColor = Color * mix(dark, light, a);
fgColor = mix(fgColor,fogColor,fog(fogDist));
//mix onto tri-borders
float mixer = clamp(exp(1.0-50.0*min(tePatchDistance.x,min(tePatchDistance.y,tePatchDistance.z))),0,1);
fgColor = mix(fgColor, grid, mixer);
mixer = clamp(exp(1.0-50.0*min(tePatchDistance.x+tePatchDistance.y,min(tePatchDistance.x+tePatchDistance.z,tePatchDistance.y+tePatchDistance.z))),0,1);
fgColor = mix(fgColor, point, mixer);
}

15
shaders/map/fragmentShadow.shader Normal file
View File

@ -0,0 +1,15 @@
#version 330
smooth in vec3 teNormal;
smooth in vec3 tePosition;
smooth in float fogDist;
smooth in float gmix;
in vec4 teColor;
in vec3 tePatchDistance;
uniform mat4 ViewMatrix;
uniform mat4 ProjectionMatrix;
void main(void)
{
}

48
shaders/map/tessControl.shader Normal file
View File

@ -0,0 +1,48 @@
#version 330
#extension GL_ARB_tessellation_shader : require
layout(vertices = 3) out;
in vec3 vPosition[];
in vec4 vColor[];
in vec3 vNormal[];
out vec3 tcPosition[];
out vec4 tcColor[];
out vec3 tcNormal[];
uniform float TessLevelInner = 1.0; // controlled by keyboard buttons
uniform float TessLevelOuter = 1.0; // controlled by keyboard buttons
uniform mat4 ProjectionMatrix;
uniform mat4 ViewMatrix;
uniform mat3 NormalMatrix;
#define ID gl_InvocationID
void main()
{
tcPosition[ID] = vPosition[ID];
tcColor[ID] = vColor[ID];
tcNormal[ID] = vNormal[ID];
float dist = (ProjectionMatrix * ViewMatrix * vec4(vPosition[ID], 1)).z;
if (ID == 0) {
if (dist < 30) {
gl_TessLevelInner[0] = TessLevelInner;
gl_TessLevelOuter[0] = TessLevelOuter;
gl_TessLevelOuter[1] = TessLevelOuter;
gl_TessLevelOuter[2] = TessLevelOuter;
} else if (dist < 50) {
gl_TessLevelInner[0] = max(TessLevelInner-1.0,1.0);
gl_TessLevelOuter[0] = max(TessLevelOuter-1.0,1.0);
gl_TessLevelOuter[1] = max(TessLevelOuter-1.0,1.0);
gl_TessLevelOuter[2] = max(TessLevelOuter-1.0,1.0);
} else if (dist < 100) {
gl_TessLevelInner[0] = max(TessLevelInner-2.0,1.0);
gl_TessLevelOuter[0] = max(TessLevelOuter-2.0,1.0);
gl_TessLevelOuter[1] = max(TessLevelOuter-2.0,1.0);
gl_TessLevelOuter[2] = max(TessLevelOuter-2.0,1.0);
} else {
gl_TessLevelInner[0] = 1.0;
gl_TessLevelOuter[0] = 1.0;
gl_TessLevelOuter[1] = 1.0;
gl_TessLevelOuter[2] = 1.0;
}
}
}

152
shaders/map/tessEval.shader Normal file
View File

@ -0,0 +1,152 @@
#version 330
#extension GL_ARB_tessellation_shader : require
//#include "shaders/3rdParty/noise.glsl"
vec3 mod289(vec3 x) {
return x - floor(x * (1.0 / 289.0)) * 289.0;
}
vec4 mod289(vec4 x) {
return x - floor(x * (1.0 / 289.0)) * 289.0;
}
vec4 permute(vec4 x) {
return mod289(((x*34.0)+1.0)*x);
}
vec4 taylorInvSqrt(vec4 r)
{
return 1.79284291400159 - 0.85373472095314 * r;
}
float snoise(vec3 v)
{
const vec2 C = vec2(1.0/6.0, 1.0/3.0) ;
const vec4 D = vec4(0.0, 0.5, 1.0, 2.0);
// First corner
vec3 i = floor(v + dot(v, C.yyy) );
vec3 x0 = v - i + dot(i, C.xxx) ;
// Other corners
vec3 g = step(x0.yzx, x0.xyz);
vec3 l = 1.0 - g;
vec3 i1 = min( g.xyz, l.zxy );
vec3 i2 = max( g.xyz, l.zxy );
// x0 = x0 - 0.0 + 0.0 * C.xxx;
// x1 = x0 - i1 + 1.0 * C.xxx;
// x2 = x0 - i2 + 2.0 * C.xxx;
// x3 = x0 - 1.0 + 3.0 * C.xxx;
vec3 x1 = x0 - i1 + C.xxx;
vec3 x2 = x0 - i2 + C.yyy; // 2.0*C.x = 1/3 = C.y
vec3 x3 = x0 - D.yyy; // -1.0+3.0*C.x = -0.5 = -D.y
// Permutations
i = mod289(i);
vec4 p = permute( permute( permute(
i.z + vec4(0.0, i1.z, i2.z, 1.0 ))
+ i.y + vec4(0.0, i1.y, i2.y, 1.0 ))
+ i.x + vec4(0.0, i1.x, i2.x, 1.0 ));
// Gradients: 7x7 points over a square, mapped onto an octahedron.
// The ring size 17*17 = 289 is close to a multiple of 49 (49*6 = 294)
float n_ = 0.142857142857; // 1.0/7.0
vec3 ns = n_ * D.wyz - D.xzx;
vec4 j = p - 49.0 * floor(p * ns.z * ns.z); // mod(p,7*7)
vec4 x_ = floor(j * ns.z);
vec4 y_ = floor(j - 7.0 * x_ ); // mod(j,N)
vec4 x = x_ *ns.x + ns.yyyy;
vec4 y = y_ *ns.x + ns.yyyy;
vec4 h = 1.0 - abs(x) - abs(y);
vec4 b0 = vec4( x.xy, y.xy );
vec4 b1 = vec4( x.zw, y.zw );
//vec4 s0 = vec4(lessThan(b0,0.0))*2.0 - 1.0;
//vec4 s1 = vec4(lessThan(b1,0.0))*2.0 - 1.0;
vec4 s0 = floor(b0)*2.0 + 1.0;
vec4 s1 = floor(b1)*2.0 + 1.0;
vec4 sh = -step(h, vec4(0.0));
vec4 a0 = b0.xzyw + s0.xzyw*sh.xxyy ;
vec4 a1 = b1.xzyw + s1.xzyw*sh.zzww ;
vec3 p0 = vec3(a0.xy,h.x);
vec3 p1 = vec3(a0.zw,h.y);
vec3 p2 = vec3(a1.xy,h.z);
vec3 p3 = vec3(a1.zw,h.w);
//Normalise gradients
vec4 norm = taylorInvSqrt(vec4(dot(p0,p0), dot(p1,p1), dot(p2, p2), dot(p3,p3)));
p0 *= norm.x;
p1 *= norm.y;
p2 *= norm.z;
p3 *= norm.w;
// Mix final noise value
vec4 m = max(0.6 - vec4(dot(x0,x0), dot(x1,x1), dot(x2,x2), dot(x3,x3)), 0.0);
m = m * m;
return 42.0 * dot( m*m, vec4( dot(p0,x0), dot(p1,x1),
dot(p2,x2), dot(p3,x3) ) );
}
layout(triangles, equal_spacing, cw) in;
in vec3 tcPosition[];
in vec4 tcColor[];
in vec3 tcNormal[];
out vec4 teColor;
smooth out vec3 tePosition;
smooth out vec3 teNormal;
smooth out float fogDist;
smooth out float gmix; //mixture of gravel
out vec3 tePatchDistance;
//out vec3 tePatchDistance;
//constant projection matrix
uniform mat4 ProjectionMatrix;
uniform mat4 ViewMatrix;
uniform mat3 NormalMatrix;
void main()
{
//NORMAL
vec3 n0 = gl_TessCoord.x * tcNormal[0];
vec3 n1 = gl_TessCoord.y * tcNormal[1];
vec3 n2 = gl_TessCoord.z * tcNormal[2];
vec3 tessNormal = normalize(n0 + n1 + n2);
teNormal = NormalMatrix * tessNormal;
//POSITION
vec3 p0 = gl_TessCoord.x * tcPosition[0];
vec3 p1 = gl_TessCoord.y * tcPosition[1];
vec3 p2 = gl_TessCoord.z * tcPosition[2];
tePosition = p0 + p1 + p2;
tePatchDistance = gl_TessCoord;
//sin(a,b) = length(cross(a,b))
float i0 = (1-gl_TessCoord.x)*gl_TessCoord.x * length(cross(tcNormal[0],tessNormal));
float i1 = (1-gl_TessCoord.y)*gl_TessCoord.y * length(cross(tcNormal[1],tessNormal));
float i2 = (1-gl_TessCoord.z)*gl_TessCoord.z * length(cross(tcNormal[2],tessNormal));
float standout = i0+i1+i2;
tePosition = tePosition+tessNormal*standout;
vec3 tmp = tePosition;//+clamp(tePosition,0,0.05)*snoise(tePosition/2);
tePosition = vec3(tePosition.x, tmp.y, tePosition.z);
gl_Position = ProjectionMatrix * ViewMatrix * vec4(tePosition, 1);
fogDist = gl_Position.z;
//COLOR-BLENDING
vec4 c0 = (1-exp(gl_TessCoord.x)) * tcColor[0];
vec4 c1 = (1-exp(gl_TessCoord.y)) * tcColor[1];
vec4 c2 = (1-exp(gl_TessCoord.z)) * tcColor[2];
teColor = (c0 + c1 + c2)/((1-exp(gl_TessCoord.x))+(1-exp(gl_TessCoord.y))+(1-exp(gl_TessCoord.z)));
//mix gravel based on incline (sin (normal,up))
gmix = length(cross(tessNormal, vec3(0,1,0)));
}

18
shaders/map/vertex.shader Normal file
View File

@ -0,0 +1,18 @@
#version 330
//vertex-data
in vec4 Color;
in vec3 Position;
in vec3 Normal;
//output-data for later stages
out vec4 vColor;
out vec3 vPosition;
out vec3 vNormal;
void main()
{
vPosition = Position;
vNormal = Normal;
vColor = Color;
}

119
shaders/mapobjects/doneShader/fragment.shader Normal file
View File

@ -0,0 +1,119 @@
#version 330
//#include "3rdParty/noise.glsl"
vec3 mod289(vec3 x) {
return x - floor(x * (1.0 / 289.0)) * 289.0;
}
vec4 mod289(vec4 x) {
return x - floor(x * (1.0 / 289.0)) * 289.0;
}
vec4 permute(vec4 x) {
return mod289(((x*34.0)+1.0)*x);
}
vec4 taylorInvSqrt(vec4 r)
{
return 1.79284291400159 - 0.85373472095314 * r;
}
float snoise(vec3 v)
{
const vec2 C = vec2(1.0/6.0, 1.0/3.0) ;
const vec4 D = vec4(0.0, 0.5, 1.0, 2.0);
// First corner
vec3 i = floor(v + dot(v, C.yyy) );
vec3 x0 = v - i + dot(i, C.xxx) ;
// Other corners
vec3 g = step(x0.yzx, x0.xyz);
vec3 l = 1.0 - g;
vec3 i1 = min( g.xyz, l.zxy );
vec3 i2 = max( g.xyz, l.zxy );
// x0 = x0 - 0.0 + 0.0 * C.xxx;
// x1 = x0 - i1 + 1.0 * C.xxx;
// x2 = x0 - i2 + 2.0 * C.xxx;
// x3 = x0 - 1.0 + 3.0 * C.xxx;
vec3 x1 = x0 - i1 + C.xxx;
vec3 x2 = x0 - i2 + C.yyy; // 2.0*C.x = 1/3 = C.y
vec3 x3 = x0 - D.yyy; // -1.0+3.0*C.x = -0.5 = -D.y
// Permutations
i = mod289(i);
vec4 p = permute( permute( permute(
i.z + vec4(0.0, i1.z, i2.z, 1.0 ))
+ i.y + vec4(0.0, i1.y, i2.y, 1.0 ))
+ i.x + vec4(0.0, i1.x, i2.x, 1.0 ));
// Gradients: 7x7 points over a square, mapped onto an octahedron.
// The ring size 17*17 = 289 is close to a multiple of 49 (49*6 = 294)
float n_ = 0.142857142857; // 1.0/7.0
vec3 ns = n_ * D.wyz - D.xzx;
vec4 j = p - 49.0 * floor(p * ns.z * ns.z); // mod(p,7*7)
vec4 x_ = floor(j * ns.z);
vec4 y_ = floor(j - 7.0 * x_ ); // mod(j,N)
vec4 x = x_ *ns.x + ns.yyyy;
vec4 y = y_ *ns.x + ns.yyyy;
vec4 h = 1.0 - abs(x) - abs(y);
vec4 b0 = vec4( x.xy, y.xy );
vec4 b1 = vec4( x.zw, y.zw );
//vec4 s0 = vec4(lessThan(b0,0.0))*2.0 - 1.0;
//vec4 s1 = vec4(lessThan(b1,0.0))*2.0 - 1.0;
vec4 s0 = floor(b0)*2.0 + 1.0;
vec4 s1 = floor(b1)*2.0 + 1.0;
vec4 sh = -step(h, vec4(0.0));
vec4 a0 = b0.xzyw + s0.xzyw*sh.xxyy ;
vec4 a1 = b1.xzyw + s1.xzyw*sh.zzww ;
vec3 p0 = vec3(a0.xy,h.x);
vec3 p1 = vec3(a0.zw,h.y);
vec3 p2 = vec3(a1.xy,h.z);
vec3 p3 = vec3(a1.zw,h.w);
//Normalise gradients
vec4 norm = taylorInvSqrt(vec4(dot(p0,p0), dot(p1,p1), dot(p2, p2), dot(p3,p3)));
p0 *= norm.x;
p1 *= norm.y;
p2 *= norm.z;
p3 *= norm.w;
// Mix final noise value
vec4 m = max(0.6 - vec4(dot(x0,x0), dot(x1,x1), dot(x2,x2), dot(x3,x3)), 0.0);
m = m * m;
return 42.0 * dot( m*m, vec4( dot(p0,x0), dot(p1,x1),
dot(p2,x2), dot(p3,x3) ) );
}
float fog(float dist) {
dist = max(0,dist - 50);
dist = dist * 0.05;
// dist = dist*dist;
return 1-exp(-dist);
}
smooth in vec2 teTexCoord;
smooth in vec3 teNormal;
smooth in vec3 tePosition;
smooth in float fogDist;
smooth in float gmix;
out vec4 fgColor;
uniform mat4 ViewMatrix;
uniform mat4 ProjectionMatrix;
void main(void)
{
fgColor = vec4(1.0,0.0,1.0,1.0);
}

27
shaders/mapobjects/doneShader/tessControl.shader Normal file
View File

@ -0,0 +1,27 @@
#version 330
#extension GL_ARB_tessellation_shader : require
layout(vertices = 3) out;
in vec3 vPosition[];
in vec2 vTexCoord[];
in vec3 vNormal[];
out vec3 tcPosition[];
out vec2 tcTexCoord[];
out vec3 tcNormal[];
uniform float TessLevelInner = 1.0; // controlled by keyboard buttons
uniform float TessLevelOuter = 1.0; // controlled by keyboard buttons
#define ID gl_InvocationID
void main()
{
tcPosition[ID] = vPosition[ID];
tcTexCoord[ID] = vTexCoord[ID];
tcNormal[ID] = vNormal[ID];
if (ID == 0) {
gl_TessLevelInner[0] = TessLevelInner;
gl_TessLevelOuter[0] = TessLevelOuter;
gl_TessLevelOuter[1] = TessLevelOuter;
gl_TessLevelOuter[2] = TessLevelOuter;
}
}

151
shaders/mapobjects/doneShader/tessEval.shader Normal file
View File

@ -0,0 +1,151 @@
#version 330
#extension GL_ARB_tessellation_shader : require
//#include "shaders/3rdParty/noise.glsl"
vec3 mod289(vec3 x) {
return x - floor(x * (1.0 / 289.0)) * 289.0;
}
vec4 mod289(vec4 x) {
return x - floor(x * (1.0 / 289.0)) * 289.0;
}
vec4 permute(vec4 x) {
return mod289(((x*34.0)+1.0)*x);
}
vec4 taylorInvSqrt(vec4 r)
{
return 1.79284291400159 - 0.85373472095314 * r;
}
float snoise(vec3 v)
{
const vec2 C = vec2(1.0/6.0, 1.0/3.0) ;
const vec4 D = vec4(0.0, 0.5, 1.0, 2.0);
// First corner
vec3 i = floor(v + dot(v, C.yyy) );
vec3 x0 = v - i + dot(i, C.xxx) ;
// Other corners
vec3 g = step(x0.yzx, x0.xyz);
vec3 l = 1.0 - g;
vec3 i1 = min( g.xyz, l.zxy );
vec3 i2 = max( g.xyz, l.zxy );
// x0 = x0 - 0.0 + 0.0 * C.xxx;
// x1 = x0 - i1 + 1.0 * C.xxx;
// x2 = x0 - i2 + 2.0 * C.xxx;
// x3 = x0 - 1.0 + 3.0 * C.xxx;
vec3 x1 = x0 - i1 + C.xxx;
vec3 x2 = x0 - i2 + C.yyy; // 2.0*C.x = 1/3 = C.y
vec3 x3 = x0 - D.yyy; // -1.0+3.0*C.x = -0.5 = -D.y
// Permutations
i = mod289(i);
vec4 p = permute( permute( permute(
i.z + vec4(0.0, i1.z, i2.z, 1.0 ))
+ i.y + vec4(0.0, i1.y, i2.y, 1.0 ))
+ i.x + vec4(0.0, i1.x, i2.x, 1.0 ));
// Gradients: 7x7 points over a square, mapped onto an octahedron.
// The ring size 17*17 = 289 is close to a multiple of 49 (49*6 = 294)
float n_ = 0.142857142857; // 1.0/7.0
vec3 ns = n_ * D.wyz - D.xzx;
vec4 j = p - 49.0 * floor(p * ns.z * ns.z); // mod(p,7*7)
vec4 x_ = floor(j * ns.z);
vec4 y_ = floor(j - 7.0 * x_ ); // mod(j,N)
vec4 x = x_ *ns.x + ns.yyyy;
vec4 y = y_ *ns.x + ns.yyyy;
vec4 h = 1.0 - abs(x) - abs(y);
vec4 b0 = vec4( x.xy, y.xy );
vec4 b1 = vec4( x.zw, y.zw );
//vec4 s0 = vec4(lessThan(b0,0.0))*2.0 - 1.0;
//vec4 s1 = vec4(lessThan(b1,0.0))*2.0 - 1.0;
vec4 s0 = floor(b0)*2.0 + 1.0;
vec4 s1 = floor(b1)*2.0 + 1.0;
vec4 sh = -step(h, vec4(0.0));
vec4 a0 = b0.xzyw + s0.xzyw*sh.xxyy ;
vec4 a1 = b1.xzyw + s1.xzyw*sh.zzww ;
vec3 p0 = vec3(a0.xy,h.x);
vec3 p1 = vec3(a0.zw,h.y);
vec3 p2 = vec3(a1.xy,h.z);
vec3 p3 = vec3(a1.zw,h.w);
//Normalise gradients
vec4 norm = taylorInvSqrt(vec4(dot(p0,p0), dot(p1,p1), dot(p2, p2), dot(p3,p3)));
p0 *= norm.x;
p1 *= norm.y;
p2 *= norm.z;
p3 *= norm.w;
// Mix final noise value
vec4 m = max(0.6 - vec4(dot(x0,x0), dot(x1,x1), dot(x2,x2), dot(x3,x3)), 0.0);
m = m * m;
return 42.0 * dot( m*m, vec4( dot(p0,x0), dot(p1,x1),
dot(p2,x2), dot(p3,x3) ) );
}
layout(triangles, equal_spacing, cw) in;
in vec3 tcPosition[];
in vec2 tcTexCoord[];
in vec3 tcNormal[];
smooth out vec2 teTexCoord
smooth out vec3 tePosition;
smooth out vec3 teNormal;
smooth out float fogDist;
smooth out float gmix; //mixture of gravel
//out vec3 tePatchDistance;
//constant projection matrix
uniform mat4 ProjectionMatrix;
uniform mat4 ViewMatrix;
uniform mat3 NormalMatrix;
void main()
{
//base color
color = vec4(1.0,0.0,1.0,1.0);
//NORMAL
vec3 n0 = gl_TessCoord.x * tcNormal[0];
vec3 n1 = gl_TessCoord.y * tcNormal[1];
vec3 n2 = gl_TessCoord.z * tcNormal[2];
vec3 tessNormal = normalize(n0 + n1 + n2);
teNormal = NormalMatrix * tessNormal;
//POSITION
vec3 p0 = gl_TessCoord.x * tcPosition[0];
vec3 p1 = gl_TessCoord.y * tcPosition[1];
vec3 p2 = gl_TessCoord.z * tcPosition[2];
tePosition = p0 + p1 + p2;
//sin(a,b) = length(cross(a,b))
float i0 = (1-gl_TessCoord.x)*gl_TessCoord.x * length(cross(tcNormal[0],tessNormal));
float i1 = (1-gl_TessCoord.y)*gl_TessCoord.y * length(cross(tcNormal[1],tessNormal));
float i2 = (1-gl_TessCoord.z)*gl_TessCoord.z * length(cross(tcNormal[2],tessNormal));
float standout = i0+i1+i2;
tePosition = tePosition+tessNormal*standout;
tePosition = tePosition+0.05*snoise(tePosition);
gl_Position = ProjectionMatrix * ViewMatrix * vec4(tePosition, 1);
fogDist = gl_Position.z;
//COLOR-BLENDING
vec2 t0 = gl_TessCoord.x * tcTexCoord[0];
vec2 t1 = gl_TessCoord.y * tcTexCoord[1];
vec2 t2 = gl_TessCoord.z * tcTexCoord[2];
teColor = t0 + t1 + t2;
//mix gravel based on incline (sin (normal,up))
gmix = length(cross(tessNormal, vec3(0,1,0)));
}

18
shaders/mapobjects/doneShader/vertex.shader Normal file
View File

@ -0,0 +1,18 @@
#version 330
//vertex-data
in vec3 Position;
in vec3 Normal;
in vec2 TexCoord;
//output-data for later stages
out vec2 vTexCoord;
out vec3 vPosition;
out vec3 vNormal;
void main()
{
vPosition = Position;
vNormal = Normal;
vTexCoord = TexCoord;
}

21
shaders/mapobjects/fragment.shader Normal file
View File

@ -0,0 +1,21 @@
#version 330
in vec3 vPosition;
in vec3 vNormal;
out vec4 fgColor;
uniform mat4 ViewMatrix;
void main () {
//heliospheric lighting
vec4 light = vec4(1.0,1.0,1.0,1.0);
vec4 dark = vec4(0.0,0.0,0.0,1.0);
//direction to sun from origin
vec3 lightDir = normalize(ViewMatrix * vec4(5.0,5.0,1.0,0.0)).xyz;
float costheta = dot(vNormal, lightDir);
float a = costheta * 0.5 + 0.5;
fgColor = vec4(0.5,0.5,0.5,1)*mix(dark,light,a);
}

21
shaders/mapobjects/vertex.shader Normal file
View File

@ -0,0 +1,21 @@
#version 330
layout(location=0) in vec3 Position;
layout(location=1) in vec3 Normal;
layout(location=2) in vec2 TexCoord;
uniform mat4 ProjectionMatrix;
uniform mat4 ViewMatrix;
uniform mat3 NormalMatrix;
uniform vec3 PositionOffset = vec3(5,2,5);
uniform float TessLevelInner = 1.0; // controlled by keyboard buttons
uniform float TessLevelOuter = 1.0; // controlled by keyboard buttons
out vec3 vPosition;
out vec3 vNormal;
void main () {
vPosition = Position;
//gl_Position = vec4(Position,1);
gl_Position = ProjectionMatrix * ViewMatrix * vec4(PositionOffset + Position, 1);
vNormal = Normal;
}

11
shaders/ui/fragment.shader Normal file
View File

@ -0,0 +1,11 @@
#version 110
uniform sampler2D tex[2];
varying vec2 texcoord;
void main()
{
vec4 map = texture2D(tex[0], texcoord);
vec4 hud = texture2D(tex[1], vec2(texcoord.x,-texcoord.y));
gl_FragColor = vec4(mix(map.rgb,hud.rgb,hud.a),1.0);
}

10
shaders/ui/vertex.shader Normal file
View File

@ -0,0 +1,10 @@
#version 110
attribute vec2 position;
varying vec2 texcoord;
void main()
{
gl_Position = vec4(position, 0.0, 1.0);
texcoord = position * vec2(0.5) + vec2(0.5);
}

366
src/Importer/IQM/Parser.hs Normal file
View File

@ -0,0 +1,366 @@
{-# LANGUAGE RankNTypes #-}
-- | Parser for IQM-Files
--
-- Assumes that the file is stored with 32-Bit-BigEndian-Ints
module Importer.IQM.Parser (parseIQM) where
import Importer.IQM.Types
import Data.Attoparsec.ByteString.Char8
import Data.Attoparsec.ByteString
import Data.Attoparsec.Binary
import Data.ByteString.Char8 (pack)
import Data.ByteString (split, null, ByteString)
import Data.ByteString.Unsafe (unsafeUseAsCString)
import qualified Data.ByteString as B
import Graphics.GLUtil
import Graphics.Rendering.OpenGL.GL.StateVar (($=))
import Graphics.Rendering.OpenGL.GL.BufferObjects
import Graphics.Rendering.OpenGL.GL.VertexArrays
import Graphics.Rendering.OpenGL.GL.VertexArrayObjects
import Graphics.Rendering.OpenGL.GL.VertexSpec
import Graphics.Rendering.OpenGL.GL.ObjectName
import Data.Word
import Data.Int
import Unsafe.Coerce
import Control.Monad.Trans.State
import Control.Monad.Trans.Class
import Control.Monad
import Foreign.Ptr
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils
import Foreign.Storable (sizeOf)
import Prelude as P hiding (take, null)
import Render.Misc (printPtrAsFloatArray, printPtrAsUByteArray, printPtrAsWord32Array, withVBO, checkError)
-- | helper-function for creating an integral out of [8-Bit Ints]
_w8ToInt :: Integral a => a -> a -> a
_w8ToInt i add = 256*i + add
-- | shorthand-function for parsing Word8 into Integrals
_parseNum :: (Integral a, Integral b) => [a] -> b
_parseNum = foldl1 _w8ToInt . map fromIntegral
-- | read a 16-Bit Int from Parsing-Input and log 2 bytes in our Parsing-Monad
--
-- begins with _ to defeat ghc-warnings. Rename if used!
_int16 :: CParser Word16
_int16 = do
ret <- lift $ do
a <- anyWord8 :: Parser Word8
b <- anyWord8 :: Parser Word8
return $ _parseNum [b,a]
modify (+2)
return ret
-- | read a 32-Bit Int from Parsing-Input and log 4 bytes in our Parsing-Monad
_int32 :: CParser Int32
_int32 = do
ret <- lift $ do
a <- anyWord8 :: Parser Word8
b <- anyWord8 :: Parser Word8
c <- anyWord8 :: Parser Word8
d <- anyWord8 :: Parser Word8
return $ _parseNum [d,c,b,a]
modify (+4)
return ret
w32leCParser :: CParser Word32
w32leCParser = do
ret <- lift anyWord32le
modify (+4)
return ret
-- | Parser for the header
readHeader :: CParser IQMHeader
readHeader = do
_ <- lift $ string (pack "INTERQUAKEMODEL\0")
modify (+16)
v <- w32leCParser
lift $ when (v /= 2) $ fail "Version /= 2.\nThis Parser only supports Version 2 of the InterQuake-Model IQM"
-- when v /= 2 then fail parsing.
size' <- w32leCParser
flags' <- w32leCParser
num_text' <- w32leCParser
ofs_text' <- w32leCParser
num_meshes' <- w32leCParser
ofs_meshes' <- w32leCParser
num_vertexarrays' <- w32leCParser
num_vertexes' <- w32leCParser
ofs_vertexarrays' <- w32leCParser
num_triangles' <- w32leCParser
ofs_triangles' <- w32leCParser
ofs_adjacency' <- w32leCParser
num_joints' <- w32leCParser
ofs_joints' <- w32leCParser
num_poses' <- w32leCParser
ofs_poses' <- w32leCParser
num_anims' <- w32leCParser
ofs_anims' <- w32leCParser
num_frames' <- w32leCParser
num_framechannels' <- w32leCParser
ofs_frames' <- w32leCParser
ofs_bounds' <- w32leCParser
num_comment' <- w32leCParser
ofs_comment' <- w32leCParser
num_extensions' <- w32leCParser
ofs_extensions' <- w32leCParser
return IQMHeader { version = v
, filesize = size'
, flags = fromIntegral flags'
, num_text = num_text'
, ofs_text = ofs_text'
, num_meshes = num_meshes'
, ofs_meshes = ofs_meshes'
, num_vertexarrays = num_vertexarrays'
, num_vertexes = num_vertexes'
, ofs_vertexarrays = ofs_vertexarrays'
, num_triangles = num_triangles'
, ofs_triangles = ofs_triangles'
, ofs_adjacency = ofs_adjacency'
, num_joints = num_joints'
, ofs_joints = ofs_joints'
, num_poses = num_poses'
, ofs_poses = ofs_poses'
, num_anims = num_anims'
, ofs_anims = ofs_anims'
, num_frames = num_frames'
, num_framechannels = num_framechannels'
, ofs_frames = ofs_frames'
, ofs_bounds = ofs_bounds'
, num_comment = num_comment'
, ofs_comment = ofs_comment'
, num_extensions = num_extensions'
, ofs_extensions = ofs_extensions'
}
-- | Parser for Mesh-Structure
readMesh :: CParser IQMMesh
readMesh = do
name <- w32leCParser
mat <- w32leCParser
fv <- w32leCParser
nv <- w32leCParser
ft <- w32leCParser
nt <- w32leCParser
return IQMMesh
{ meshName = if name == 0 then Nothing else Just (Mesh name)
, meshMaterial = mat
, meshFirstVertex = fv
, meshNumVertexes = nv
, meshFirstTriangle = ft
, meshNumTriangles = nt
}
-- | helper to read n consecutive Meshes tail-recursive
readMeshes :: Int -> CParser [IQMMesh]
readMeshes 1 = do
m <- readMesh
return [m]
readMeshes n = do
m <- readMesh
ms <- readMeshes (n-1)
return $ m:ms
-- | Parser for Mesh-Structure
readVAF :: CParser IQMVertexArray
readVAF = do
vat <- rawEnumToVAT =<< w32leCParser
flags' <- w32leCParser
format <- rawEnumToVAF =<< w32leCParser
size <- w32leCParser
offset <- w32leCParser
return $ IQMVertexArray vat (fromIntegral flags') format (fromIntegral size) offset nullPtr
-- | helper to read n consecutive Meshes tail-recursive
readVAFs :: Int -> CParser [IQMVertexArray]
readVAFs 1 = do
f <- readVAF
return [f]
readVAFs n = do
f <- readVAF
fs <- readVAFs (n-1)
return $ f:fs
-- | helper-Notation for subtracting 2 integral values of different kind in the precision
-- of the target-kind
(.-) :: forall a a1 a2.
(Num a, Integral a2, Integral a1) =>
a1 -> a2 -> a
(.-) a b = fromIntegral a - fromIntegral b
infix 5 .-
-- | skips (=drops) all input until the internal counter is at a given bytecount
--
-- Fails the parser if given bytecount is lower than the internal counter as we
-- read sequentially and do not do backtracking
skipToCounter :: Integral a => a -> CParser ()
skipToCounter a = do
let d = fromIntegral a
c <- get
when (d < c) $ fail "wanting to skip to counter already passed"
_ <- lift $ take $ d .- c
put d
-- | Parses an IQM-File and handles back the Haskell-Structure
--
-- Does a 2-Pass-Parsing. Reads in Structure on first pass (O(n))and
-- fills the Structure in a 2nd Pass from Offsets (O(memcpy'd bytes)).
parseIQM :: String -> IO IQM
parseIQM a =
do
f <- B.readFile a
-- Parse Headers/Offsets to BareIQM
let result = parse doIQMparse f
bare <- case result of
Done _ x -> return x
y -> error $ show y
-- Fill Vertex-Array with buffer objects and data of Offsets
va' <- mapM (readInVAO f (num_vertexes.bareheader $ bare)) (barevertexArrays bare)
-- create VAO with attached vbos
vao <- makeVAO $ do
-- generate array buffers
--
--for pos,normal,tex:
let initBuffer :: AttribLocation -> IQMVertexArrayType -> [IQMVertexArray] -> Int -> IO ()
initBuffer l t vas len' =
do
-- find array with type t, otherwise abort hard.
let (IQMVertexArray _ _ format num _ dat) = case filter (\(IQMVertexArray ty _ _ _ _ _) -> ty == t) vas of
[b] -> b
_ -> error $ "Current object does not support " ++ (show t)
buf <- genObjectName
-- create buffer and write data
withVBO buf (toBufferTargetfromVAType t) $ do
-- copy data
bufferData (toBufferTargetfromVAType t) $= (fromIntegral len' * fromIntegral num * (fromIntegral.vaSize) format,dat,StaticDraw)
checkError "bufferData vao"
-- tell layout
vertexAttribPointer l $= (ToFloat, VertexArrayDescriptor num Float 0 nullPtr)
let len = (fromIntegral.num_vertexes.bareheader) bare
initBuffer (AttribLocation 0) IQMPosition va' len
initBuffer (AttribLocation 1) IQMNormal va' len
initBuffer (AttribLocation 2) IQMTexCoord va' len
-- for indices
tbo <- genObjectName
tris <- withVBO tbo ArrayBuffer $ do
let
len = (fromIntegral.num_triangles.bareheader) bare
byteLen = len * 3 * sizeOf (undefined :: Word32)
data' = skipDrop ((fromIntegral.ofs_triangles.bareheader) bare) byteLen f
p <- mallocBytes byteLen
unsafeUseAsCString data' (\s -> copyBytes p s byteLen)
withVBO tbo ElementArrayBuffer $ do
bufferData ElementArrayBuffer $= (fromIntegral byteLen, p, StaticDraw)
checkError "bufferData tris"
return $ castPtr p
--putStrLn "Triangles:"
--printPtrAsWord32Array tris ((*3).fromIntegral.num_triangles.bareheader $ bare) 3
--print bare
return $ IQM
{ header = bareheader bare
, texts = baretexts bare
, meshes = baremeshes bare
, vertexArrays = va'
, vertexBufferObjects = []
, vertexArrayObject = vao
, triangles = tris
, triangleBufferObject = tbo
}
createVAO :: [(IQMVertexArray, BufferObject)] -> IO ()
createVAO bo = do
--print bo
initVAO (AttribLocation 0) IQMPosition bo
initVAO (AttribLocation 1) IQMNormal bo
initVAO (AttribLocation 2) IQMTexCoord bo
initVAO :: AttribLocation -> IQMVertexArrayType -> [(IQMVertexArray, BufferObject)] -> IO ()
initVAO l t bo = do
--print $ concat ["adding ", show t, " to vertexBufferObject"]
let (IQMVertexArray _ _ _ num _ _,buf) = case filter (\(IQMVertexArray ty _ _ _ _ _, _) -> ty == t) bo of
[(a,b)] -> (a,b)
_ -> error "IQM-Object not render-able with current shader-mechanics"
bindBuffer (toBufferTargetfromVAType t) $= Just buf
vertexAttribArray l $= Enabled
vertexAttribPointer l $= (ToFloat, VertexArrayDescriptor num Float 0 nullPtr)
-- | Creates a BufferObject on the Graphicscard for each BufferObject
toVBOfromVAO :: IQMVertexArray -> IO BufferObject
toVBOfromVAO (IQMVertexArray type' _ _ num _ ptr) =
fromPtr (toBufferTargetfromVAType type') (fromIntegral num) ptr
-- | translates from VA-type to BufferTarget
toBufferTargetfromVAType :: IQMVertexArrayType -> BufferTarget
toBufferTargetfromVAType IQMPosition = ArrayBuffer
toBufferTargetfromVAType IQMTexCoord = ArrayBuffer
toBufferTargetfromVAType IQMNormal = ArrayBuffer
toBufferTargetfromVAType IQMBlendIndexes = ElementArrayBuffer
toBufferTargetfromVAType IQMBlendWeights = ArrayBuffer
toBufferTargetfromVAType IQMColor = ArrayBuffer
toBufferTargetfromVAType _ = ArrayBuffer
-- | Allocates memory for the Vertex-data and copies it over there
-- from the given input-String
--
-- Note: The String-Operations are O(1), so only O(numberOfCopiedBytes)
-- is needed in term of computation.
readInVAO :: ByteString -> Word32 -> IQMVertexArray -> IO IQMVertexArray
readInVAO d vcount (IQMVertexArray type' a format num offset ptr) =
do
let
numElems = fromIntegral vcount * fromIntegral num
byteLen = numElems * vaSize format
data' = skipDrop (fromIntegral offset) byteLen d
unless (ptr == nullPtr) $ error $ "Error reading Vertex-Array: Double Read of " ++ show type'
p <- mallocBytes byteLen
putStrLn $ concat ["Allocating ", show vcount ,"x", show num,"x",show (vaSize format)," = ", show byteLen, " Bytes at ", show p, " for ", show type']
putStrLn $ concat ["Filling starting at ", show offset, " with: "]
unsafeUseAsCString data' (\s -> copyBytes p s byteLen)
{-case type' of
IQMBlendIndexes -> printPtrAsUByteArray p numElems 4
IQMBlendWeights -> printPtrAsUByteArray p numElems 4
IQMTexCoord -> printPtrAsFloatArray p numElems 2
_ -> printPtrAsFloatArray p numElems 3-}
return $ IQMVertexArray type' a format num offset $ castPtr p
-- | Real internal Parser.
--
-- Consumes the String only once, thus in O(n). But all Data-Structures are
-- not allocated and copied. readInVAO has to be called on each one.
doIQMparse :: Parser BareIQM
doIQMparse =
flip evalStateT 0 $ --evaluate parser with state starting at 0
do
h <- readHeader --read header
skipToCounter $ ofs_text h --skip 0-n bytes to get to text
text <- lift . take . fromIntegral $ num_text h --read texts
modify . (+) . fromIntegral $ num_text h --put offset forward
skipToCounter $ ofs_meshes h --skip 0-n bytes to get to meshes
meshes' <- readMeshes $ fromIntegral $ num_meshes h --read meshes
skipToCounter $ ofs_vertexarrays h --skip 0-n bytes to get to Vertex-Arrays
vaf <- readVAFs $ fromIntegral $ num_vertexarrays h --read Vertex-Arrays
return BareIQM
{ bareheader = h
, baretexts = filter (not.null) (split (unsafeCoerce '\0') text)
, baremeshes = meshes'
, barevertexArrays = vaf
}
-- | Helper-Function for Extracting a random substring out of a Bytestring
-- by the Offsets provided.
--
-- O(1).
skipDrop :: Int -- ^ Bytes to drop
-> Int -- ^ Bytes to take
-> ByteString
-> ByteString
skipDrop a b= B.take b . B.drop a

221
src/Importer/IQM/Types.hs Normal file
View File

@ -0,0 +1,221 @@
-- {-# LANGUAGE ExistentialQuantification, RankNTypes, CPP, BangPatterns #-}
-- | Word32 or Word64 - depending on implementation. Format just specifies "uint".
-- 4-Byte in the documentation indicates Word32 - but not specified!
module Importer.IQM.Types where
import Control.Monad.Trans.State.Lazy (StateT)
import Data.Int
import Data.Word
import Data.ByteString
import Data.Attoparsec.ByteString.Char8
import Foreign.Ptr
import Graphics.Rendering.OpenGL.Raw.Types
import Prelude as P
import Foreign.Storable
import Foreign.C.Types
import Graphics.Rendering.OpenGL.GL.BufferObjects hiding (Offset)
import Graphics.Rendering.OpenGL.GL.VertexArrayObjects
-- | Mesh-Indices to distinguish the meshes referenced
newtype Mesh = Mesh Word32 deriving (Show, Eq)
-- | State-Wrapped Parser-Monad which is capable of counting the
-- Bytes read for offset-gap reasons
type CParser a = StateT Int64 Parser a
-- | Alias
type Flags = GLbitfield -- ^ Alias for UInt32
-- | Alias
type Offset = Word32 -- ^ Alias for UInt32
-- | Alias
type Index = GLuint -- ^ Alias for UInt32
-- | Alias
type NumComponents = GLsizei -- ^ Alias for UInt32
-- | Data-BLOB inside IQM
type IQMData = Ptr IQMVertexArrayFormat -- ^ Pointer for Data
-- | Header of IQM-Format.
--
-- ofs_* fields are relative to the beginning of the iqmheader struct
--
-- ofs_* fields are set to 0 when data is empty
--
-- ofs_* fields are aligned at 4-byte-boundaries
data IQMHeader = IQMHeader
{ version :: !Word32 -- ^ Must be 2
, filesize :: !Word32
, flags :: !Flags
, num_text :: !Word32
, ofs_text :: !Offset
, num_meshes :: !Word32
, ofs_meshes :: !Offset
, num_vertexarrays :: !Word32
, num_vertexes :: !Word32
, ofs_vertexarrays :: !Offset
, num_triangles :: !Word32
, ofs_triangles :: !Offset
, ofs_adjacency :: !Offset
, num_joints :: !Word32
, ofs_joints :: !Offset
, num_poses :: !Word32
, ofs_poses :: !Offset
, num_anims :: !Word32
, ofs_anims :: !Offset
, num_frames :: !Word32
, num_framechannels :: !Word32
, ofs_frames :: !Offset
, ofs_bounds :: !Offset
, num_comment :: !Word32
, ofs_comment :: !Offset
, num_extensions :: !Word32 -- ^ stored as linked list, not as array.
, ofs_extensions :: !Offset
} deriving (Show, Eq)
-- | Format of an IQM-Mesh Structure.
--
-- Read it like a Header of the Meshes lateron in the Format
data IQMMesh = IQMMesh
{ meshName :: Maybe Mesh
, meshMaterial :: Word32
, meshFirstVertex :: Word32
, meshNumVertexes :: Word32
, meshFirstTriangle :: Word32
, meshNumTriangles :: Word32
} deriving (Show, Eq)
-- | Format of IQM-Triangle Structure
data IQMTriangle = IQMTriangle VertexIndex VertexIndex VertexIndex
-- | Type-Alias for Word32 indicating an index on vertices in IQMMesh
type VertexIndex = Word32
-- | Type-Alias for Word32 indicating an index on IQMTriangle
type TriangleIndex = Word32
-- | From the IQM-Format-Description:
--
-- each value is the index of the adjacent triangle for edge 0, 1, and 2, where ~0 (= -1)
-- indicates no adjacent triangle indexes are relative to the iqmheader.ofs_triangles array
-- and span all meshes, where 0 is the first triangle, 1 is the second, 2 is the third, etc.
data IQMAdjacency = IQMAdjacency TriangleIndex TriangleIndex TriangleIndex
-- | Format of a whole IQM-File
--
-- still unfinished!
data IQM = IQM
{ header :: IQMHeader
, texts :: [ByteString]
, meshes :: [IQMMesh]
, vertexArrays :: [IQMVertexArray]
, vertexBufferObjects :: [BufferObject]
, vertexArrayObject :: VertexArrayObject
, triangles :: Ptr Word32
, triangleBufferObject :: BufferObject
} deriving (Show, Eq)
-- | Internal format of an unprocessed IQM
--
-- for internal and temporary use only
data BareIQM = BareIQM
{ bareheader :: IQMHeader
, baretexts :: [ByteString]
, baremeshes :: [IQMMesh]
, barevertexArrays :: [IQMVertexArray]
} deriving (Show, Eq)
-- | Different Vertex-Array-Types in IQM
--
-- Custom Types have to be > 0x10 as of specification
data IQMVertexArrayType = IQMPosition
| IQMTexCoord
| IQMNormal
| IQMTangent
| IQMBlendIndexes
| IQMBlendWeights
| IQMColor
| IQMCustomVAT Word32
deriving (Show, Eq)
-- | Lookup-Function for internal enum to VertexArrayFormat
rawEnumToVAT :: Word32 -> CParser IQMVertexArrayType
rawEnumToVAT 0 = return IQMPosition
rawEnumToVAT 1 = return IQMTexCoord
rawEnumToVAT 2 = return IQMNormal
rawEnumToVAT 3 = return IQMTangent
rawEnumToVAT 4 = return IQMBlendIndexes
rawEnumToVAT 5 = return IQMBlendWeights
rawEnumToVAT 6 = return IQMColor
rawEnumToVAT a = return $ IQMCustomVAT a
-- | Vetrex-Array-Format of the data found at offset
data IQMVertexArrayFormat = IQMbyte
| IQMubyte
| IQMshort
| IQMushort
| IQMint
| IQMuint
| IQMhalf
| IQMfloat
| IQMdouble
-- | Unknown Word32
deriving (Show, Eq)
-- | Get the Size (in Bytes) of the given IQMVertexArrayFormat-Struct
vaSize :: IQMVertexArrayFormat -> Int
vaSize IQMbyte = sizeOf (undefined :: CSChar)
vaSize IQMubyte = sizeOf (undefined :: CUChar)
vaSize IQMshort = sizeOf (undefined :: CShort)
vaSize IQMushort = sizeOf (undefined :: CUShort)
vaSize IQMint = sizeOf (undefined :: CInt)
vaSize IQMuint = sizeOf (undefined :: CUInt)
vaSize IQMhalf = sizeOf (undefined :: Word16) --TODO: Find 16-Bit-Float-Datatype FIXME!
vaSize IQMfloat = sizeOf (undefined :: CFloat)
vaSize IQMdouble = sizeOf (undefined :: CDouble)
--mallocVArray :: Storable a => IQMVertexArrayFormat -> Int -> IO (Ptr a)
--mallocVArray IQMbyte n = mallocArray n :: IO (Ptr CSChar)
--mallocVArray IQMubyte n = mallocArray n :: IO (Ptr CUChar)
-- | Lookup-Function for internal enum to VertexArrayFormat
rawEnumToVAF :: Word32 -> CParser IQMVertexArrayFormat
rawEnumToVAF 0 = return IQMbyte
rawEnumToVAF 1 = return IQMubyte
rawEnumToVAF 2 = return IQMshort
rawEnumToVAF 3 = return IQMushort
rawEnumToVAF 4 = return IQMint
rawEnumToVAF 5 = return IQMuint
rawEnumToVAF 6 = return IQMhalf
rawEnumToVAF 7 = return IQMfloat
rawEnumToVAF 8 = return IQMdouble
--rawEnumToVAF a = return $ Unknown a
rawEnumToVAF a = fail $ P.concat ["unrecognized enum(",show a,") in VertexArrayFormat"]
-- | A Vertex-Array-Definiton.
--
-- The Vertex starts at Offset and has num_vertexes * NumComponents entries.
--
-- All Vertex-Arrays seem to have the same number of components, just differ in Type, Format
-- and Flags
data IQMVertexArray = IQMVertexArray
IQMVertexArrayType
Flags
IQMVertexArrayFormat
NumComponents
Offset
IQMData
deriving (Eq)
instance Show IQMVertexArray where
show (IQMVertexArray t fl fo nc off dat) = "IQMVertexArray (Type: " ++ show t ++
", Flags: " ++ show fl ++
", Format: " ++ show fo ++
", NumComponents: " ++ show nc ++
", Offset: " ++ show off ++
", Data at: " ++ show dat ++
")"

370
src/Main.hs Normal file
View File

@ -0,0 +1,370 @@
{-# LANGUAGE BangPatterns, DoAndIfThenElse #-}
module Main where
import Graphics.Rendering.OpenGL.GL.Texturing.Specification (texImage2D,TextureTarget2D(Texture2D))
import Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable (PixelInternalFormat(..))
import Graphics.Rendering.OpenGL.GL.Texturing.Objects (textureBinding)
import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (TextureFilter(..),textureFilter)
-- Monad-foo and higher functional stuff
import Control.Monad (unless, when, join)
import Control.Arrow ((***))
import Control.Lens ((^.), (.~), (%~))
-- data consistency/conversion
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM (TQueue, newTQueueIO, atomically)
import Control.Concurrent.STM.TVar (newTVarIO, writeTVar, readTVar, readTVarIO)
import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify)
import Data.Functor ((<$>))
import Data.Monoid (mappend)
import qualified Data.HashMap.Strict as Map
-- FFI
import Foreign.Marshal.Array (pokeArray)
import Foreign.Marshal.Alloc (allocaBytes)
-- GUI
import qualified Graphics.UI.SDL as SDL
-- Render
import qualified Graphics.Rendering.OpenGL.GL as GL
import Graphics.Rendering.OpenGL.Raw.Core31
import Data.Time (getCurrentTime, diffUTCTime)
-- Our modules
import Render.Misc (checkError, createFrustum, curb,
genColorData)
import Render.Render (initRendering,
initMapShader,
initHud, render)
import Render.Types
import UI.Callbacks
import Map.Graphics
import Map.Creation (exportedMap)
import Types
import Importer.IQM.Parser
--import Data.Attoparsec.Char8 (parseTest)
--import qualified Data.ByteString as B
-- import qualified Debug.Trace as D (trace)
--------------------------------------------------------------------------------
testParser :: String -> IO ()
testParser a = print =<< parseIQM a
{-do
f <- B.readFile a
putStrLn "reading in:"
putStrLn $ show f
putStrLn "parsed:"
parseTest parseIQM f-}
--------------------------------------------------------------------------------
main :: IO ()
main = do
let initialWidth = 1024
initialHeight = 600
SDL.withInit [SDL.InitVideo, SDL.InitAudio, SDL.InitEvents, SDL.InitTimer] $ --also: InitNoParachute -> faster, without parachute!
SDL.withWindow "Pioneers" (SDL.Position 100 100) (SDL.Size initialWidth initialHeight)
[SDL.WindowOpengl -- we want openGL
,SDL.WindowShown -- window should be visible
,SDL.WindowResizable -- and resizable
,SDL.WindowInputFocus -- focused (=> active)
,SDL.WindowMouseFocus -- Mouse into it
--,WindowInputGrabbed-- never let go of input (KB/Mouse)
] $ \window' -> do
SDL.withOpenGL window' $ do
SDL.glSwapWindow window' -- swap to get the glew-stuff out of the way
--Create Renderbuffer & Framebuffer
-- We will render to this buffer to copy the result into textures
renderBuffer <- GL.genObjectName
frameBuffer <- GL.genObjectName
GL.bindFramebuffer GL.Framebuffer GL.$= frameBuffer
GL.bindRenderbuffer GL.Renderbuffer GL.$= renderBuffer
(SDL.Size fbWidth fbHeight) <- SDL.glGetDrawableSize window'
initRendering
--generate map vertices
curMap <- exportedMap
(glMap', tex, dtex) <- initMapShader 4 =<< getMapBufferObject curMap
tex' <- newTVarIO tex
dtex' <- newTVarIO dtex
eventQueue <- newTQueueIO :: IO (TQueue SDL.Event)
now <- getCurrentTime
--font <- TTF.openFont "fonts/ttf-04B_03B_/04B_03B_.TTF" 10
--TTF.setFontStyle font TTFNormal
--TTF.setFontHinting font TTFHNormal
let
fov = 90 --field of view
near = 1 --near plane
far = 500 --far plane
ratio = fromIntegral fbWidth / fromIntegral fbHeight
frust = createFrustum fov near far ratio
cam' <- newTVarIO CameraState
{ _xAngle = pi/6
, _yAngle = pi/2
, _zDist = 10
, _frustum = frust
, _camObject = createFlatCam 25 25 curMap
}
game' <- newTVarIO GameState
{ _currentMap = curMap
}
let camStack' = Map.empty
glHud' <- initHud
let zDistClosest' = 2
zDistFarthest' = zDistClosest' + 10
--TODO: Move near/far/fov to state for runtime-changability & central storage
aks = ArrowKeyState {
_up = False
, _down = False
, _left = False
, _right = False
}
env = Env
{ _eventsChan = eventQueue
, _windowObject = window'
, _zDistClosest = zDistClosest'
, _zDistFarthest = zDistFarthest'
}
state = State
{ _window = WindowState
{ _width = fbWidth
, _height = fbHeight
, _shouldClose = False
}
, _io = IOState
{ _clock = now
, _tessClockFactor = 0
, _tessClockTime = now
}
, _camera = cam'
, _mapTexture = tex'
, _mapDepthTexture = dtex'
, _camStack = camStack'
, _keyboard = KeyboardState
{ _arrowsPressed = aks
}
, _gl = GLState
{ _glMap = glMap'
, _glHud = glHud'
, _glRenderbuffer = renderBuffer
, _glFramebuffer = frameBuffer
}
, _game = game'
, _ui = createGUI initialWidth initialHeight
}
putStrLn "init done."
uncurry mappend <$> evalRWST (adjustWindow >> run) env state
putStrLn "shutdown complete."
--SDL.glDeleteContext mainGlContext
--SDL.destroyRenderer renderer
--destroyWindow window
-- Main game loop
run :: Pioneers ()
run = do
env <- ask
-- draw Scene
draw
liftIO $ SDL.glSwapWindow (env ^. windowObject)
-- getEvents & process
processEvents
-- update State
state <- get
-- get cursor-keys - if pressed
--TODO: Add sin/cos from stateYAngle
(kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement
liftIO $ atomically $ do
cam <- readTVar (state ^. camera)
game' <- readTVar (state ^. game)
let
multc = cos $ cam ^. yAngle
mults = sin $ cam ^. yAngle
modx x' = x' - 0.2 * kxrot * multc
- 0.2 * kyrot * mults
mody y' = y' + 0.2 * kxrot * mults
- 0.2 * kyrot * multc
cam' <- return $ camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)) (game' ^. currentMap)) $ cam
writeTVar (state ^. camera) cam'
{-
--modify the state with all that happened in mt time.
mt <- liftIO GLFW.getTime
modify $ \s -> s
{
}
-}
(mt,tc,sleepAmount,frameTime,hC) <- liftIO $ do
let double = fromRational.toRational :: (Real a) => a -> Double
targetFramerate = 60.0
targetFrametime = 1.0/targetFramerate
--targetFrametimeμs = targetFrametime * 1000000.0
now <- getCurrentTime
let diff = max 0.001 $ diffUTCTime now (state ^. io.clock) -- get time-diffs
updatediff = diffUTCTime now (state ^. io.tessClockTime) -- get diff to last update
title = unwords ["Pioneers @ ",show ((round . double $ 1.0/diff)::Int),"fps"]
ddiff = double diff
SDL.setWindowTitle (env ^. windowObject) title
let sleepAmount = floor ((targetFrametime - double diff)*1000000) :: Int -- get time until next frame in microseconds
clockFactor = (state ^. io.tessClockFactor)
noChange = ((+)0 :: Int -> Int)
(tessChange, hasChanged)
| updatediff < 5 = (noChange,False) -- at least 5 sec since last update
| (clockFactor < (75*targetFrametime)) && (state ^. gl.glMap.stateTessellationFactor < 5) = (((+)1 :: Int -> Int),True)
-- > last 100 frames had > 25% leftover (on avg.)
| (clockFactor > (110*targetFrametime)) && (state ^. gl.glMap.stateTessellationFactor > 1) = ((flip (-) 1 :: Int -> Int),True)
-- > last 100 frames had < 90% of target-fps
| otherwise = (noChange,False) -- 0ms > x > 10% -> keep settings
when (sleepAmount > 0) $ threadDelay sleepAmount
now' <- getCurrentTime
return (now',tessChange,sleepAmount,ddiff,hasChanged)
-- set state with new clock-time
--liftIO $ putStrLn $ unwords ["clockFactor:",show (state ^. io.tessClockFactor),"\ttc:", show (tc (state ^. gl.glMap.stateTessellationFactor)),"\tsleep ",show frameTime,"ms"]
if hC then
do
liftIO $ putStrLn $ unwords ["modifying TessFactor to",show $ tc $ state ^. gl.glMap.stateTessellationFactor]
modify $ (io.clock .~ mt)
. (gl.glMap.stateTessellationFactor %~ tc)
. (io.tessClockFactor %~ (((+) frameTime).((*) 0.99)))
. (io.tessClockTime .~ mt)
else
modify $ (io.clock .~ mt)
. (io.tessClockFactor %~ (((+) frameTime).((*) 0.99)))
-- liftIO $ putStrLn $ concat $ ["TessFactor at: ",show (state ^. gl.glMap.stateTessellationFactor), " - slept for ",show sleepAmount, "μs."]
shouldClose' <- return $ state ^. window.shouldClose
unless shouldClose' run
draw :: Pioneers ()
draw = do
state <- get
when (state ^. ui . uiHasChanged) prepareGUI
render
getArrowMovement :: Pioneers (Int, Int)
getArrowMovement = do
state <- get
aks <- return $ state ^. (keyboard.arrowsPressed)
let
horz = left' + right'
vert = up'+down'
left' = if aks ^. left then -1 else 0
right' = if aks ^. right then 1 else 0
up' = if aks ^. up then -1 else 0
down' = if aks ^. down then 1 else 0
return (horz,vert)
adjustWindow :: Pioneers ()
adjustWindow = do
state <- get
let fbWidth = state ^. window.width
fbHeight = state ^. window.height
fov = 90 --field of view
near = 1 --near plane
far = 100 --far plane
ratio = fromIntegral fbWidth / fromIntegral fbHeight
frust = createFrustum fov near far ratio
liftIO $ glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight)
liftIO $ atomically $ do
cam <- readTVar (state ^. camera)
cam' <- return $ frustum .~ frust $ cam
writeTVar (state ^. camera) cam'
rb <- liftIO $ do
-- bind ints to CInt for lateron.
let fbCWidth = (fromInteger.toInteger) fbWidth
fbCHeight = (fromInteger.toInteger) fbHeight
-- free old renderbuffer & create new (reuse is NOT advised!)
GL.deleteObjectName (state ^. gl.glRenderbuffer)
renderBuffer <- GL.genObjectName
GL.bindRenderbuffer GL.Renderbuffer GL.$= renderBuffer
GL.renderbufferStorage
GL.Renderbuffer -- use the only available renderbuffer
-- - must be this constant.
GL.DepthComponent' -- 32-bit float-rgba-color
(GL.RenderbufferSize fbCWidth fbCHeight) -- size of buffer
let hudtexid = state ^. gl.glHud.hudTexture
smaptexid = state ^. gl.glMap.shadowMapTexture
maptexid <- readTVarIO (state ^. mapTexture)
mapdepthtexid <- readTVarIO (state ^. mapDepthTexture)
-- create & clear textures for hud & background (map)
allocaBytes (fbWidth*fbHeight*4) $ \ptr -> do
--default to ugly pink to see if
--somethings go wrong.
let imData = genColorData (fbWidth*fbHeight) [255,0,255,0]
--putStrLn $ show imData
pokeArray ptr imData
-- HUD
textureBinding Texture2D GL.$= Just hudtexid
textureFilter Texture2D GL.$= ((Linear', Nothing), Linear')
texImage2D Texture2D GL.NoProxy 0 RGBA8 (GL.TextureSize2D fbCWidth fbCHeight) 0
(GL.PixelData GL.RGBA GL.UnsignedByte ptr)
textureBinding Texture2D GL.$= Nothing
-- MAP
textureBinding Texture2D GL.$= Just maptexid
textureFilter Texture2D GL.$= ((Linear', Nothing), Linear')
texImage2D Texture2D GL.NoProxy 0 RGBA8 (GL.TextureSize2D fbCWidth fbCHeight) 0
(GL.PixelData GL.RGBA GL.UnsignedByte ptr)
textureBinding Texture2D GL.$= Nothing
-- create & clear map depth texture
allocaBytes (fbWidth*fbHeight) $ \ptr -> do
let smapdata = genColorData (fbWidth*fbHeight) [0]
pokeArray ptr smapdata
textureBinding Texture2D GL.$= Just mapdepthtexid
textureFilter Texture2D GL.$= ((Linear', Nothing), Linear')
texImage2D Texture2D GL.NoProxy 0 GL.DepthComponent16 (GL.TextureSize2D fbCWidth fbCHeight) 0
(GL.PixelData GL.DepthComponent GL.UnsignedByte ptr)
textureBinding Texture2D GL.$= Nothing
-- create & clear depth texture for shadows
allocaBytes (2048*2048) $ \ptr -> do
let smapdata = genColorData (2048*2048) [0]
pokeArray ptr smapdata
textureBinding Texture2D GL.$= Just smaptexid
textureFilter Texture2D GL.$= ((Nearest,Nothing), Nearest)
texImage2D Texture2D GL.NoProxy 0 GL.DepthComponent16 (GL.TextureSize2D 2048 2048) 0
(GL.PixelData GL.DepthComponent GL.UnsignedByte ptr)
textureBinding Texture2D GL.$= Nothing
checkError "setting up HUD-Tex"
return renderBuffer
modify $ gl.glRenderbuffer .~ rb
modify $ ui.uiHasChanged .~ True
processEvents :: Pioneers ()
processEvents = do
me <- liftIO SDL.pollEvent
case me of
Just e -> do
processEvent e
processEvents
Nothing -> return ()
processEvent :: SDL.Event -> Pioneers ()
processEvent e = do
eventCallback e
-- env <- ask
case SDL.eventData e of
SDL.Window _ winEvent -> -- windowID event
case winEvent of
SDL.Closing ->
modify $ window.shouldClose .~ True
SDL.Resized {SDL.windowResizedTo=size} -> do
modify $ (window . width .~ SDL.sizeWidth size)
. (window . height .~ SDL.sizeHeight size)
adjustWindow
SDL.SizeChanged ->
adjustWindow
_ -> return ()
_ -> return ()

87
src/Map/Creation.hs Normal file
View File

@ -0,0 +1,87 @@
module Map.Creation
where
import Map.Types
import Data.Array
import System.Random
-- entirely empty map, only uses the minimal constructor
mapEmpty :: PlayMap
mapEmpty = array ((0,0), (199,199)) [((a,b), Node (a,b) (fromIntegral a, (if even b then (fromIntegral b) else(fromIntegral b) - 0.5), 1) Grass BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199]]
exportedMap :: IO PlayMap
exportedMap = do mounts <- mnt
return $ aplAll mounts mapEmpty
-- | Generate a new Map of given Type and Size
--
-- TODO:
-- 1. Should take Size -> Type -> Playmap
-- 2. plug together helper-functions for that terraintype
newMap :: MapType -> (Int, Int) -> PlayMap
newMap = undefined
aplByPlace :: (Node -> Node) -> ((Int,Int) -> Bool) -> PlayMap -> PlayMap
aplByPlace f g mp = array (bounds mp) (map (\(ab,c) -> if g ab then (ab, f c) else (ab,c)) (assocs mp))
aplByNode :: (Node -> Node) -> (Node -> Bool) -> PlayMap -> PlayMap
aplByNode f g mp = array (bounds mp) (map (\(ab,c) -> (if g c then (ab, f c) else (ab,c))) (assocs mp))
aplAll :: [a -> a] -> a -> a
aplAll fs m = foldl (\ n f -> f n) m fs
aplAllM :: Monad m => [m a -> m a] -> m a -> m a
aplAllM fs x = foldl (\ n f -> f n) x fs
-- general 3D-Gaussian
gauss3Dgeneral :: Floating q =>
q -- ^ Amplitude
-> q -- ^ Origin on X-Achsis
-> q -- ^ Origin on Z-Achsis
-> q -- ^ Sigma on X
-> q -- ^ Sigma on Z
-> q -- ^ Coordinate in question on X
-> q -- ^ Coordinate in question on Z
-> q -- ^ elevation on coordinate in question
gauss3Dgeneral amp x0 z0 sX sZ x z = amp * exp(-(((x-x0)^(2 :: Int)/(2 * sX^(2 :: Int)))+((z-z0)^(2 :: Int)/(2 * sZ^(2 :: Int)))))
-- | Basic Terrain-Generator. Will not implement "abnormal" Stuff for given Biome
-- (like Deserts on Grass-Islands or Grass on Deserts)
--
-- TODO: Implement Desert-Generator
heightToTerrain :: MapType -> YCoord -> TileType
heightToTerrain GrassIslandMap y
| y < 0.1 = Ocean
| y < 0.2 = Beach
| y < 1.5 = Grass
| y < 3 = Hill
| otherwise = Mountain
heightToTerrain _ _ = undefined
lake :: Int -> PlayMap -> PlayMap
lake = undefined
river :: Int -> PlayMap -> PlayMap
river = undefined
mnt :: IO [PlayMap -> PlayMap]
mnt = do g <- newStdGen
let seeds = take 50 $ randoms g
return $ map gaussMountain seeds
gaussMountain :: Int -> PlayMap -> PlayMap
gaussMountain seed mp = aplByPlace (liftUp c) (\(_,_) -> True) mp
where
gs = map mkStdGen (map (*seed) [1..])
c = let ((a,b), (x,y)) = bounds mp in (head (randomRs (a,x) (gs !! 0)), (head (randomRs (b,y) (gs !! 1))))
amp = head $ randomRs ((2.0, 5.0) :: (Double, Double)) (gs !! 2)
sig = head $ randomRs ((2.0, 8.0) :: (Double, Double)) (gs !! 3)
htt = heightToTerrain
-- TODO: Fix Lambda to True with sensible function, maybe rework giveNeighbourhood in Map.Map
liftUp :: (Int, Int) -> Node -> Node
liftUp (gx,gz) (Node (x,z) (rx,rz,y) _ b pl pa r s) = let y_neu = max y e
in Node (x,z) (rx, rz, y_neu) (htt GrassIslandMap y_neu) b pl pa r s
where e = gauss3Dgeneral amp (fromIntegral gx) (fromIntegral gz) sig sig rx rz

210
src/Map/Graphics.hs Normal file
View File

@ -0,0 +1,210 @@
{-# LANGUAGE OverloadedStrings, BangPatterns #-}
module Map.Graphics
(
mapVertexArrayDescriptor,
fgColorIndex,
fgNormalIndex,
fgVertexIndex,
mapStride,
getMapBufferObject
)
where
import Data.Array.IArray
import Prelude as P
--import Graphics.Rendering.OpenGL.GL
import Graphics.Rendering.OpenGL.GL.BufferObjects
import Graphics.Rendering.OpenGL.GL.ObjectName
import Graphics.Rendering.OpenGL.GL.StateVar
import Graphics.Rendering.OpenGL.GL.VertexArrays
import Graphics.Rendering.OpenGL.GL.VertexSpec
import Graphics.Rendering.OpenGL.Raw.Core31
import Foreign.Marshal.Array (withArray)
import Foreign.Storable (sizeOf)
import Foreign.Ptr (Ptr, nullPtr, plusPtr)
import Render.Misc (checkError)
import Linear
import Control.Arrow ((***))
import Map.Types
type Height = Double
type MapEntry = (
Height,
TileType
)
type GraphicsMap = Array (Int, Int) MapEntry
-- converts from classical x/z to striped version of a map
convertToStripeMap :: PlayMap -> PlayMap
convertToStripeMap mp = array (stripify l, stripify u) (map (stripify *** strp) (assocs mp))
where
(l,u) = bounds mp
stripify :: (Int,Int) -> (Int,Int)
stripify (x,z) = (if even z then 2*x else 2*x+1, z `div` 2)
strp :: Node -> Node
strp (Node i (x,z,y) tt bi pli p ri si) = Node (stripify i) (x,z,y) tt bi pli p ri si
-- extract graphics information from Playmap
convertToGraphicsMap :: PlayMap -> GraphicsMap
convertToGraphicsMap mp = array (bounds mp) [(i, graphicsyfy (mp ! i))| i <- indices mp]
where
graphicsyfy :: Node -> MapEntry
graphicsyfy (Node _ (_,_,y) t _ _ _ _ _ ) = (y, t)
lineHeight :: GLfloat
lineHeight = 0.8660254
-- Number of GLfloats per Stride
numComponents :: Int
numComponents = 10
mapStride :: Stride
mapStride = fromIntegral (sizeOf (0.0 :: GLfloat) * numComponents)
bufferObjectPtr :: Integral a => a -> Ptr GLfloat
bufferObjectPtr = plusPtr (nullPtr :: Ptr GLfloat) . fromIntegral
mapVertexArrayDescriptor :: NumComponents -> NumComponents -> VertexArrayDescriptor GLfloat
mapVertexArrayDescriptor count' offset =
VertexArrayDescriptor count' Float mapStride (bufferObjectPtr (fromIntegral offset * sizeOf (0 :: GLfloat)) ) --(fromIntegral numComponents * offset))
fgColorIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat)
fgColorIndex = (ToFloat, mapVertexArrayDescriptor 4 0) --color first
fgNormalIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat)
fgNormalIndex = (ToFloat, mapVertexArrayDescriptor 3 4) --normal after color
fgVertexIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat)
fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 7) --vertex after normal
getMapBufferObject :: PlayMap -> IO (BufferObject, NumArrayIndices)
getMapBufferObject eMap = do
myMap' <- return $ convertToGraphicsMap $ convertToStripeMap eMap
! myMap <- return $ generateTriangles myMap'
len <- return $ fromIntegral $ P.length myMap `div` numComponents
putStrLn $ P.unwords ["num verts in map:",show len]
bo <- genObjectName -- create a new buffer
bindBuffer ArrayBuffer $= Just bo -- bind buffer
withArray myMap $ \buffer ->
bufferData ArrayBuffer $= (fromIntegral $ sizeOf (0 :: GLfloat) * P.length myMap,
buffer,
StaticDraw)
checkError "initBuffer"
return (bo,len)
--generateTriangles :: PlayMap -> [GLfloat]
generateTriangles :: GraphicsMap -> [GLfloat]
generateTriangles map' =
let ((xl,yl),(xh,yh)) = bounds map' in
P.concat [P.concat $ P.map (generateFirstTriLine map' y) [xl .. xh - 2]
++ P.map (generateSecondTriLine map' (y == yh) y) [xl .. xh - 2]
| y <- [yl..yh]]
generateFirstTriLine :: GraphicsMap -> Int -> Int -> [GLfloat]
generateFirstTriLine map' y x =
P.concat $
if even x then
[ lookupVertex map' x y,
lookupVertex map' (x + 1) y,
lookupVertex map' (x + 2) y
]
else
[ lookupVertex map' x y,
lookupVertex map' (x + 2) y,
lookupVertex map' (x + 1) y
]
generateSecondTriLine :: GraphicsMap -> Bool -> Int -> Int -> [GLfloat]
generateSecondTriLine map' False y x =
P.concat $
if even x then
[ lookupVertex map' x (y + 1),
lookupVertex map' (x + 2) (y + 1),
lookupVertex map' (x + 1) y
]
else
[ lookupVertex map' x y,
lookupVertex map' (x + 1) (y + 1),
lookupVertex map' (x + 2) y
]
generateSecondTriLine _ True _ _ = []
lookupVertex :: GraphicsMap -> Int -> Int -> [GLfloat]
lookupVertex map' x y =
let
(cr, cg, cb) = colorLookup map' (x,y)
(V3 vx vy vz) = coordLookup (x,y) $ heightLookup map' (x,y)
(V3 nx ny nz) = normalLookup map' x y
--TODO: calculate normals correctly!
in
[
cr, cg, cb, 1.0, -- RGBA Color
nx, ny, nz, -- 3 Normal
vx, vy, vz -- 3 Vertex
]
normalLookup :: GraphicsMap -> Int -> Int -> V3 GLfloat
normalLookup map' x y = normalize $ normN + normNE + normSE + normS + normSW + normNW
where
--Face Normals
normN = cross (vNE-vC) (vNW-vC)
normNE = cross (vE -vC) (vNE-vC)
normSE = cross (vSE-vC) (vE -vC)
normS = cross (vSW-vC) (vSE-vC)
normSW = cross (vW -vC) (vSW-vC)
normNW = cross (vNW-vC) (vW -vC)
--Vertex Normals
vC = coordLookup (x,y) $ heightLookup map' (x,y)
--TODO: kill guards with eo
vNW
| even x = coordLookup (x-1,y-1) $ heightLookup map' (x-1,y-1)
| otherwise = coordLookup (x-1,y ) $ heightLookup map' (x-1,y )
vNE
| even x = coordLookup (x+1,y-1) $ heightLookup map' (x+1,y-1)
| otherwise = coordLookup (x+1,y ) $ heightLookup map' (x+1,y )
vE
| even x = coordLookup (x+2,y ) $ heightLookup map' (x+2,y )
| otherwise = coordLookup (x+2,y ) $ heightLookup map' (x+2,y )
vSE
| even x = coordLookup (x+1,y ) $ heightLookup map' (x+1,y )
| otherwise = coordLookup (x+1,y+1) $ heightLookup map' (x+1,y+1)
vSW
| even x = coordLookup (x-1,y ) $ heightLookup map' (x-1,y )
| otherwise = coordLookup (x-1,y+1) $ heightLookup map' (x-1,y+1)
vW
| even x = coordLookup (x-2,y ) $ heightLookup map' (x-2,y )
| otherwise = coordLookup (x-2,y ) $ heightLookup map' (x-2,y )
-- eo = if even x then 1 else -1
heightLookup :: GraphicsMap -> (Int,Int) -> GLfloat
heightLookup hs t = if inRange (bounds hs) t then fromRational $ toRational h else 0.0
where
(h,_) = hs ! t
colorLookup :: GraphicsMap -> (Int,Int) -> (GLfloat, GLfloat, GLfloat)
colorLookup hs t = if inRange (bounds hs) t then c else (0.0, 0.0, 0.0)
where
(_,tp) = hs ! t
c = case tp of
Ocean -> (0.50, 0.50, 1.00)
Lake -> (0.40, 0.87 ,1.00)
Beach -> (0.90, 0.85, 0.70)
Desert -> (1.00, 0.87, 0.39)
Grass -> (0.30, 0.90, 0.10)
Mountain -> (0.80, 0.80, 0.80)
Hill -> (0.50, 0.50, 0.50)
coordLookup :: (Int,Int) -> GLfloat -> V3 GLfloat
coordLookup (x,z) y =
if even x then
V3 (fromIntegral $ x `div` 2) y (fromIntegral (2 * z) * lineHeight)
else
V3 (fromIntegral (x `div` 2) + 0.5) y (fromIntegral (2 * z + 1) * lineHeight)

107
src/Map/Map.hs Normal file
View File

@ -0,0 +1,107 @@
module Map.Map where
import Map.Types
import Data.Array (bounds, (!))
import Data.List (sort, group)
import Debug.Trace
-- WARNING: Does NOT Check for neighbours exceeding maximum map coordinates yet.
unsafeGiveNeighbours :: (Int, Int) -- ^ original coordinates
-> [(Int,Int)] -- ^ list of neighbours
unsafeGiveNeighbours (x,z) = filter (not . negative) allNs
where
allNs = if even z then [(x+1,z), (x-1,z), (x,z+1), (x,z-1), (x+1,z+1), (x+1,z-1)]
else [(x+1,z), (x-1,z), (x,z+1), (x,z-1), (x-1,z+1), (x-1,z-1)]
negative :: (Int, Int) -> Bool
negative (a,b) = a < 0 || b < 0
giveNeighbours :: PlayMap -- ^ Map on which to find neighbours
-> (Int, Int) -- ^ original coordinates
-> [(Int, Int)] -- ^ list of neighbours
giveNeighbours mp (x,z) = filter (not . outOfBounds mp) allNs
where
allNs = if even z then [(x+1,z), (x-1,z), (x,z+1), (x,z-1), (x+1,z+1), (x+1,z-1)]
else [(x+1,z), (x-1,z), (x,z+1), (x,z-1), (x-1,z+1), (x-1,z-1)]
outOfBounds :: PlayMap -> (Int, Int) -> Bool
outOfBounds mp' (a,b) = let (lo,hi) = bounds mp' in
a < fst lo || b < snd lo || a > fst hi || b > snd hi
giveNeighbourhood :: PlayMap -- ^ map on which to find neighbourhood
-> Int -- ^ iterative
-> (Int, Int) -- ^ original coordinates
-> [(Int, Int)] -- ^ neighbourhood
giveNeighbourhood _ 0 (a,b) = [(a,b)]
giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in
remdups . concat $ ns : map (giveNeighbourhood mp (n-1)) ns
-- | Calculates the height of any given point on the map.
-- Does not add camera distance to ground to that.
giveMapHeight :: PlayMap
-> (Double, Double)
-> Double
giveMapHeight mop (x, z)
| outsideMap (x,z') = 0.0
| otherwise = height --sum $ map (\(p,d) -> hlu p * (d / totald)) tups
where
z' = z * 2/ sqrt 3
rx = x - (fromIntegral $ floor (x +0.5))
rz = z' - (fromIntegral $ floor (z'+0.5))
hoi = map (hlu . clmp . tadd (floor x, floor z')) mods
where
mods = [(0,0),(0,1),(1,0),(1,1)]
tadd (a,b) (c,d) = (a+c,b+d)
height = --trace (show [rx,rz] ++ show hoi)
rz * (rx * (hoi !! 0) + (1-rx) * (hoi !! 2))
+ (1-rz) * (rx * (hoi !! 1) + (1-rx) * (hoi !! 3))
outsideMap :: (Double, Double) -> Bool
outsideMap (mx, mz) = let ((a,b),(c,d)) = bounds mop
fr = fromIntegral
in mx < fr a || mx > fr c || mz < fr b || mz > fr d
-- Height LookUp on PlayMap
hlu :: (Int, Int) -> Double
hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mop ! (k,j) in y
-- reference Points
refs :: [(Int, Int)]
refs = remdups $ map (clmp . tadd (floor x, floor z')) mods
where
mods = [(-1,-1),(-1,2),(0,0),(0,1),(1,0),(1,1),(2,-1),(2,2)]
tadd (a,b) (c,d) = (a+c,b+d)
-- tupels with reference point and distance
tups = zip refs weights --map (\t -> (t, dist (x,z') t)) refs
where
weights = [1,2,1,2,4,2,1,2,1]
-- total distance of all for reference point from the point in question
totald = sum $ map snd tups
-- clamp, as she is programmed
clamp :: (Ord a) => a -> a -> a -> a
clamp mn mx = max mn . min mx
-- clamp for tupels
clmp :: (Int, Int) -> (Int, Int)
clmp (a,b) = let ((xmin,zmin),(xmax,zmax)) = bounds mop
in (clamp (xmin+2) (xmax-2) a,clamp (zmin+2) (zmax-2) b)
-- Real distance on PlayMap
dist :: (Double, Double) -> (Int, Int) -> Double
dist (x1,z1) pmp = let xf = x1 - realx
zf = z1 - realz
in sqrt $ xf*xf + zf*zf
where
realx = (\(Node _ (nx,_,_) _ _ _ _ _ _) -> nx) (mop ! pmp)
realz = (\(Node _ (_,nz,_) _ _ _ _ _ _) -> nz) (mop ! pmp)
-- removing duplicates in O(n log n), losing order and adding Ord requirement
remdups :: Ord a => [a] -> [a]
remdups = map head . group . sort

138
src/Map/Types.hs Normal file
View File

@ -0,0 +1,138 @@
module Map.Types
where
import Data.Array
type PlayMap = Array (Xindex, Zindex) Node
type Xindex = Int
type Zindex = Int
type XCoord = Double
type ZCoord = Double
type YCoord = Double
data Node = Node { mapCoordinates :: (Xindex, Zindex)
, actualCoordinates :: (XCoord, ZCoord, YCoord)
, tiletype :: TileType
, buildinfo :: BuildInfo
, playerinfo :: PlayerInfo
, pathinfo :: PathInfo
, resinfo :: ResInfo
, storinfo :: StorInfo
} deriving (Show)
data MapType = GrassIslandMap
| DesertMap
-- | Ownership information, Parameter to occupied is player number
data PlayerInfo = NoPlayer
| Occupied Int
instance Show PlayerInfo where
show (NoPlayer) = "not occupied"
show (Occupied i) = "occupied by player " ++ show i
-- | Path info, is this node part of a path and if so, where does it lead?
data PathInfo = NoPath
| Border
| Paths [(XCoord, YCoord)]
deriving (Show, Eq)
-- | What resources can be harvested here?
data ResInfo = Plain
| ResInfo Resource Amount
instance Show ResInfo where
show (Plain) = "no resources"
show (ResInfo res amt) = "Resource: " ++ show res ++ "," ++ show amt
-- | What commodities are currently stored here?
type StorInfo = [(Commodity,Amount)]
-- | What kind of structures may be erected here?
data BuildInfo = BStruc Structure
| BNothing
| BFlag
| BMine
| BSmall
| BMedium
| BLarge
instance Show BuildInfo where
show (BStruc s) = "Structure: " ++ show s
show (BNothing) = "no Structure possible"
show (BFlag) = "only flags possible"
show (BMine) = "mines possible"
show (BSmall) = "small buildings possible"
show (BMedium) = "medium buildings possible"
show (BLarge) = "large buildings possible"
data TileType = Ocean
| Beach
| Grass
| Desert
| Lake
| Hill -- ^ Accessible
| Mountain -- ^ Not accessible
deriving (Show, Eq)
data Structure = Flag -- Flag
| Woodcutter -- Huts
| Forester
| Stonemason
| Fisher
| Hunter
| Barracks
| Guardhouse
| LookoutTower
| Well
| Sawmill -- Houses
| Slaughterhouse
| Mill
| Bakery
| IronSmelter
| Metalworks
| Armory
| Mint
| Shipyard
| Brewery
| Storehouse
| Watchtower
| Catapult
| GoldMine -- Mines
| IronMine
| GraniteMine
| CoalMine
| Farm -- Castles
| PigFarm
| DonkeyBreeder
| Harbor
| Fortress
deriving (Show, Eq)
data Amount = Infinite -- Neverending supply
| Finite Int -- Finite supply
-- Extremely preliminary, expand when needed
data Commodity = WoodPlank
| Sword
| Fish
deriving Eq
data Resource = Coal
| Iron
| Gold
| Granite
| Water
| Fishes
deriving (Show, Eq)
instance Show Amount where
show (Infinite) = "inexhaustable supply"
show (Finite n) = show n ++ " left"
instance Show Commodity where
show WoodPlank = "wooden plank"
show Sword = "sword"
show Fish = "fish"

191
src/Render/Misc.hs Normal file
View File

@ -0,0 +1,191 @@
module Render.Misc where
import Control.Monad
import qualified Data.ByteString as B (ByteString)
import Data.Int (Int8)
import Data.Word (Word32,Word8)
import Graphics.Rendering.OpenGL.GL.Shaders
import Graphics.Rendering.OpenGL.GL.StateVar
import Graphics.Rendering.OpenGL.GL.StringQueries
import Graphics.Rendering.OpenGL.GLU.Errors
import Graphics.Rendering.OpenGL.GL.VertexArrayObjects
import Graphics.Rendering.OpenGL.GL.VertexArrays
import Graphics.Rendering.OpenGL.GL.VertexSpec
import Graphics.Rendering.OpenGL.GL.BufferObjects
import Graphics.UI.SDL.Types (Texture)
import System.IO (hPutStrLn, stderr)
import Linear
import Foreign.C (CFloat, CUChar)
import Foreign.Marshal.Array (peekArray)
import Foreign.Ptr (Ptr, castPtr)
up :: V3 CFloat
up = V3 0 1 0
checkError :: String -> IO ()
checkError functionName = get errors >>= mapM_ reportError
where reportError e =
hPutStrLn stderr (showError e ++ " detected in " ++ functionName)
showError (Error category message) =
"GL error " ++ show category ++ " (" ++ message ++ ")"
dumpInfo :: IO ()
dumpInfo = do
let dump message var = putStrLn . ((message ++ ": ") ++) =<< get var
dump "Vendor" vendor
dump "Renderer" renderer
dump "Version" glVersion
dump "GLSL" shadingLanguageVersion
checkError "dumpInfo"
checked :: (t -> IO ()) -> (t -> GettableStateVar Bool) -> (t -> GettableStateVar String) -> String -> t -> IO ()
checked action getStatus getInfoLog message object = do
action object
status <- get (getStatus object)
unless status $
hPutStrLn stderr . ((message ++ " log: ") ++) =<< get (getInfoLog object)
compileAndCheck :: Shader -> IO ()
compileAndCheck = checked compileShader compileStatus shaderInfoLog "compile"
compileShaderSource :: ShaderType -> B.ByteString -> IO Shader
compileShaderSource st source = do
shader <- createShader st
shaderSourceBS shader $= source
compileAndCheck shader
return shader
linkAndCheck :: Program -> IO ()
linkAndCheck = checked linkProgram linkStatus programInfoLog "link"
createProgramUsing :: [Shader] -> IO Program
createProgramUsing shaders = do
program <- createProgram
attachedShaders program $= shaders
linkAndCheck program
return program
createFrustum :: Float -> Float -> Float -> Float -> M44 CFloat
createFrustum fov n' f' rat =
let
f = realToFrac f'
n = realToFrac n'
s = realToFrac $ recip (tan $ fov*0.5 * pi / 180)
(ratw,rath) = if rat > 1 then
(1,1/realToFrac rat)
else
(realToFrac rat,1)
in
V4 (V4 (s/ratw) 0 0 0)
(V4 0 (s/rath) 0 0)
(V4 0 0 (-((f+n)/(f-n))) (-((2*f*n)/(f-n))))
(V4 0 0 (-1) 0)
-- | Creates an orthogonal frustum with given width, height, near and far-plane
createFrustumOrtho :: Float -> Float -> Float -> Float -> M44 CFloat
createFrustumOrtho w' h' n' f' =
let [w,h,n,f] = map realToFrac [w',h',n',f']
in
V4 (V4 (0.5/w) 0 0 0)
(V4 0 (0.5/h) 0 0)
(V4 0 0 (-2/(f-n)) ((-f+n)/(f-n)))
(V4 0 0 0 1)
-- from vmath.h
lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat
lookAt eye center up' =
V4
(V4 xx xy xz (-dot x eye))
(V4 yx yy yz (-dot y eye))
(V4 zx zy zz (-dot z eye))
(V4 0 0 0 1)
where
z@(V3 zx zy zz) = normalize (eye ^-^ center)
x@(V3 xx xy xz) = normalize (cross up' z)
y@(V3 yx yy yz) = normalize (cross z x)
{-getCam :: (Double, Double) -- ^ Target in x/z-Plane
-> Double -- ^ Distance from Target
-> Double -- ^ Angle around X-Axis (angle down/up)
-> Double -- ^ Angle around Y-Axis (angle left/right)
-> M44 CFloat
getCam (x',z') dist' xa' ya' = lookAt (cpos ^+^ at') at' up
where
at' = V3 x 0 z
cpos = crot !* (V3 0 0 (-dist))
crot = (
(fromQuaternion $ axisAngle upmap (xa::CFloat))
!*!
(fromQuaternion $ axisAngle (V3 0 1 0) (ya::CFloat))
) ::M33 CFloat
upmap = ((fromQuaternion $ axisAngle (V3 0 1 0) (ya::CFloat)) :: M33 CFloat)
!* (V3 1 0 0)
x = realToFrac x'
z = realToFrac z'
dist = realToFrac dist'
xa = realToFrac xa'
ya = realToFrac ya'-}
-- | Prints any Pointer as Float-Array with given number of elements and chunks.
printPtrAsFloatArray :: Ptr a -> Int -> Int -> IO ()
printPtrAsFloatArray pointer num co = do
a <- peekArray num (castPtr pointer :: Ptr CFloat)
print $ chunksOf co a
-- | Prints any Pointer as UByte-Array with given number of elements and chunks.
printPtrAsUByteArray :: Ptr a -> Int -> Int -> IO ()
printPtrAsUByteArray pointer num co = do
a <- peekArray num (castPtr pointer :: Ptr CUChar)
print $ chunksOf co a
-- | Prints any Pointer as Word32-Array with given number of elements and chunks.
printPtrAsWord32Array :: Ptr a -> Int -> Int -> IO ()
printPtrAsWord32Array pointer num co = do
a <- peekArray num (castPtr pointer :: Ptr Word32)
print $ chunksOf co a
curb :: Ord a => a -> a -> a -> a
curb l h x
| x < l = l
| x > h = h
| otherwise = x
tryWithTexture :: Maybe Texture -> (Texture -> a) -> a -> a
tryWithTexture t f fail' =
case t of
Just tex -> f tex
_ -> fail'
genColorData :: Int -- ^ Amount
-> [Word8] -- ^ [r,g,b,a], [r,g,b] - whatever should be repeatet.
-> [Word8]
genColorData n c = take (length c*n) (cycle c)
chunksOf :: Int -> [a] -> [[a]]
chunksOf _ [] = []
chunksOf a xs = take a xs : chunksOf a (drop a xs)
withVAO :: VertexArrayObject -> IO a -> IO a
withVAO v a = do
bindVertexArrayObject $= Just v
ret <- a
bindVertexArrayObject $= Nothing
return ret
withVBO :: BufferObject -> BufferTarget -> IO a -> IO a
withVBO b t a = do
bindBuffer t $= Just b
ret <- a
bindBuffer t $= Nothing
return ret
withVAA :: [AttribLocation] -> IO a -> IO a
withVAA atts action = do
mapM_ (\a -> vertexAttribArray a $= Enabled) atts
ret <- action
mapM_ (\a -> vertexAttribArray a $= Disabled) atts
return ret

538
src/Render/Render.hs Normal file
View File

@ -0,0 +1,538 @@
{-# LANGUAGE BangPatterns, InstanceSigs, ExistentialQuantification #-}
module Render.Render (initBuffer, initMapShader, initHud, initRendering, render) where
import qualified Data.ByteString as B
import Foreign.Marshal.Array (withArray)
import Foreign.Storable
import Graphics.Rendering.OpenGL.GL
import Graphics.Rendering.OpenGL.Raw.Core31
import Graphics.Rendering.OpenGL.Raw.ARB.TessellationShader
import Graphics.GLUtil.BufferObjects
import qualified Linear as L
import Control.Lens ((^.))
import Control.Monad.RWS.Strict (liftIO)
import qualified Control.Monad.RWS.Strict as RWS (get)
import Control.Concurrent.STM (readTVarIO)
import Data.Distributive (distribute, collect)
-- FFI
import Foreign (Ptr, castPtr, with, nullPtr)
import Foreign.C (CFloat)
import Map.Graphics
import Types
import Render.Misc
import Render.Types
import Importer.IQM.Parser
import Importer.IQM.Types
mapVertexShaderFile :: String
mapVertexShaderFile = "shaders/map/vertex.shader"
mapTessControlShaderFile :: String
mapTessControlShaderFile = "shaders/map/tessControl.shader"
mapTessEvalShaderFile :: String
mapTessEvalShaderFile = "shaders/map/tessEval.shader"
mapFragmentShaderFile :: String
mapFragmentShaderFile = "shaders/map/fragment.shader"
mapFragmentShaderShadowMapFile :: String
mapFragmentShaderShadowMapFile = "shaders/map/fragmentShadow.shader"
objectVertexShaderFile :: String
objectVertexShaderFile = "shaders/mapobjects/vertex.shader"
objectFragmentShaderFile :: String
objectFragmentShaderFile = "shaders/mapobjects/fragment.shader"
uiVertexShaderFile :: String
uiVertexShaderFile = "shaders/ui/vertex.shader"
uiFragmentShaderFile :: String
uiFragmentShaderFile = "shaders/ui/fragment.shader"
initBuffer :: [GLfloat] -> IO BufferObject
initBuffer varray =
let
sizeOfVarray = length varray * sizeOfComponent
sizeOfComponent = sizeOf (head varray)
in do
bufferObject <- genObjectName
bindBuffer ArrayBuffer $= Just bufferObject
withArray varray $ \buffer ->
bufferData ArrayBuffer $= (fromIntegral sizeOfVarray, buffer, StaticDraw)
checkError "initBuffer"
return bufferObject
initMapShader ::
Int -- ^ initial Tessallation-Factor
-> (BufferObject,NumArrayIndices) -- ^ Buffer with Data and DataDescriptor
-> IO (GLMapState, TextureObject, TextureObject)
initMapShader tessFac (buf, vertDes) = do
! vertexSource <- B.readFile mapVertexShaderFile
! tessControlSource <- B.readFile mapTessControlShaderFile
! tessEvalSource <- B.readFile mapTessEvalShaderFile
! fragmentSource <- B.readFile mapFragmentShaderFile
! fragmentShadowSource <- B.readFile mapFragmentShaderShadowMapFile
vertexShader <- compileShaderSource VertexShader vertexSource
checkError "compile Vertex"
tessControlShader <- compileShaderSource TessControlShader tessControlSource
checkError "compile TessControl"
tessEvalShader <- compileShaderSource TessEvaluationShader tessEvalSource
checkError "compile TessEval"
fragmentShader <- compileShaderSource FragmentShader fragmentSource
checkError "compile Frag"
fragmentShadowShader <- compileShaderSource FragmentShader fragmentShadowSource
checkError "compile Frag"
program <- createProgramUsing [vertexShader, tessControlShader, tessEvalShader, fragmentShader]
shadowProgram <- createProgramUsing [vertexShader, tessControlShader, tessEvalShader, fragmentShadowShader]
checkError "compile Program"
currentProgram $= Just program
projectionMatrixIndex <- get (uniformLocation program "ProjectionMatrix")
checkError "projMat"
viewMatrixIndex <- get (uniformLocation program "ViewMatrix")
checkError "viewMat"
modelMatrixIndex <- get (uniformLocation program "ModelMatrix")
checkError "modelMat"
normalMatrixIndex <- get (uniformLocation program "NormalMatrix")
checkError "normalMat"
tessLevelInner <- get (uniformLocation program "TessLevelInner")
checkError "TessLevelInner"
tessLevelOuter <- get (uniformLocation program "TessLevelOuter")
checkError "TessLevelOuter"
vertexIndex <- get (attribLocation program "Position")
vertexAttribArray vertexIndex $= Enabled
checkError "vertexInd"
normalIndex <- get (attribLocation program "Normal")
vertexAttribArray normalIndex $= Enabled
checkError "normalInd"
colorIndex <- get (attribLocation program "Color")
vertexAttribArray colorIndex $= Enabled
checkError "colorInd"
att <- get (activeAttribs program)
putStrLn $ unlines $ "Map-Attributes: ":map show att
putStrLn $ unlines ["Map-Indices: ", show (colorIndex, normalIndex, vertexIndex)]
tex <- genObjectName
dtex <- genObjectName
overTex <- genObjectName
textures <- genObjectNames 6
smap <- genObjectName
currentProgram $= Nothing
! vertexSource' <- B.readFile objectVertexShaderFile
! fragmentSource' <- B.readFile objectFragmentShaderFile
vertexShader' <- compileShaderSource VertexShader vertexSource'
checkError "compile Object-Vertex"
fragmentShader' <- compileShaderSource FragmentShader fragmentSource'
checkError "compile Object-Fragment"
objProgram <- createProgramUsing [vertexShader', fragmentShader']
checkError "compile Object-Program"
currentProgram $= Just objProgram
vertexIndex' <- get (attribLocation objProgram "Position")
vertexAttribArray vertexIndex $= Enabled
checkError "Object-vertexInd"
normalIndex' <- get (attribLocation objProgram "Normal")
vertexAttribArray normalIndex $= Enabled
checkError "Object-normalInd"
texIndex' <- get (attribLocation objProgram "TexCoord")
vertexAttribArray colorIndex $= Enabled
checkError "Object-texInd"
projectionMatrixIndex' <- get (uniformLocation objProgram "ProjectionMatrix")
checkError "projMat"
viewMatrixIndex' <- get (uniformLocation objProgram "ViewMatrix")
checkError "viewMat"
modelMatrixIndex' <- get (uniformLocation objProgram "ModelMatrix")
checkError "modelMat"
normalMatrixIndex' <- get (uniformLocation objProgram "NormalMatrix")
checkError "normalMat"
--tessLevelInner' <- get (uniformLocation objProgram "TessLevelInner")
--checkError "TessLevelInner"
--tessLevelOuter' <- get (uniformLocation objProgram "TessLevelOuter")
--checkError "TessLevelOuter"
vertexOffsetIndex' <- get (uniformLocation objProgram "PositionOffset")
checkError "PositionOffset"
att' <- get (activeAttribs objProgram)
putStrLn $ unlines $ "Model-Attributes: ":map show att'
uni' <- get (activeUniforms objProgram)
putStrLn $ unlines $ "Model-Uniforms: ":map show uni'
putStrLn $ unlines $ ["Model-Indices: ", show (texIndex', normalIndex', vertexIndex')]
testobj <- parseIQM "models/holzfaellerHaus1.iqm"
let objs = [MapObject testobj (L.V3 0 10 0) (MapObjectState ())]
currentProgram $= Nothing
checkError "initShader"
let sdata = MapShaderData
{ shdrVertexIndex = vertexIndex
, shdrColorIndex = colorIndex
, shdrNormalIndex = normalIndex
, shdrProjMatIndex = projectionMatrixIndex
, shdrViewMatIndex = viewMatrixIndex
, shdrModelMatIndex = modelMatrixIndex
, shdrNormalMatIndex = normalMatrixIndex
, shdrTessInnerIndex = tessLevelInner
, shdrTessOuterIndex = tessLevelOuter
}
let smodata = MapObjectShaderData
{ shdrMOVertexIndex = vertexIndex'
, shdrMOVertexOffsetIndex = vertexOffsetIndex'
, shdrMONormalIndex = normalIndex'
, shdrMOTexIndex = texIndex'
, shdrMOProjMatIndex = projectionMatrixIndex'
, shdrMOViewMatIndex = viewMatrixIndex'
, shdrMOModelMatIndex = modelMatrixIndex'
, shdrMONormalMatIndex = normalMatrixIndex'
, shdrMOTessInnerIndex = UniformLocation 0 --tessLevelInner'
, shdrMOTessOuterIndex = UniformLocation 0 --tessLevelOuter'
}
return (GLMapState
{ _mapProgram = program
, _mapShaderData = sdata
, _mapObjectShaderData = smodata
, _stateTessellationFactor = tessFac
, _stateMap = buf
, _mapVert = vertDes
, _overviewTexture = overTex
, _mapTextures = textures
, _shadowMapTexture = smap
, _mapObjects = objs
, _objectProgram = objProgram
, _shadowMapProgram = shadowProgram
}, tex, dtex)
initHud :: IO GLHud
initHud = do
! vertexSource <- B.readFile "shaders/ui/vertex.shader"
! fragmentSource <- B.readFile "shaders/ui/fragment.shader"
vertexShader <- compileShaderSource VertexShader vertexSource
checkError "compile UI-Vertex"
fragmentShader <- compileShaderSource FragmentShader fragmentSource
checkError "compile UI-Fragment"
program <- createProgramUsing [vertexShader, fragmentShader]
checkError "compile Program"
tex <- genObjectName
currentProgram $= Just program
backIndex <- get (uniformLocation program "tex[0]")
texIndex <- get (uniformLocation program "tex[1]")
checkError "ui-tex"
-- simple triangle over the whole screen.
let vertexBufferData = reverse [-1, -1, 1, -1, -1, 1, 1, 1] :: [GLfloat]
vertexIndex <- get (attribLocation program "position")
vertexAttribArray vertexIndex $= Enabled
checkError "vertexInd"
ebo <- makeBuffer ElementArrayBuffer ([0..3] :: [GLuint])
vbo <- makeBuffer ArrayBuffer vertexBufferData
att <- get (activeAttribs program)
putStrLn $ unlines $ "Attributes: ":map show att
putStrLn $ unlines $ ["Indices: ", show texIndex]
checkError "initHud"
return GLHud
{ _hudTexture = tex
, _hudTexIndex = texIndex
, _hudBackIndex = backIndex
, _hudVertexIndex = vertexIndex
, _hudVert = 4
, _hudVBO = vbo
, _hudEBO = ebo
, _hudProgram = program
}
initRendering :: IO ()
initRendering = do
clearColor $= Color4 0.6 0.7 0.8 1
depthFunc $= Just Less
glCullFace gl_BACK
checkError "initRendering"
-- | renders an IQM-Model at Position with scaling
renderIQM :: IQM -> L.V3 CFloat -> L.V3 CFloat -> IO ()
renderIQM m p@(L.V3 x y z) s@(L.V3 sx sy sz) = do
withVAO (vertexArrayObject m) $ do
withVAA [(AttribLocation 0),(AttribLocation 1)] $ do
checkError "setting array to enabled"
bindBuffer ElementArrayBuffer $= Just (triangleBufferObject m)
checkError "bindBuffer"
let n = fromIntegral.(*3).num_triangles.header $ m
--print $ concat ["drawing ", show n," triangles"]
drawElements Triangles n UnsignedInt nullPtr
checkError "drawing model"
bindBuffer ElementArrayBuffer $= Nothing
checkError "unbind buffer"
return ()
renderObject :: MapObject -> IO ()
renderObject (MapObject model pos@(L.V3 x y z) _{-state-}) =
renderIQM model pos (L.V3 1 1 1)
drawMap :: Pioneers ()
drawMap = do
state <- RWS.get
let
d = state ^. gl.glMap.mapShaderData
vi = shdrVertexIndex d
ni = shdrNormalIndex d
ci = shdrColorIndex d
numVert = state ^. gl.glMap.mapVert
map' = state ^. gl.glMap.stateMap
tessFac = state ^. gl.glMap.stateTessellationFactor
(UniformLocation tli) = shdrTessInnerIndex d
(UniformLocation tlo) = shdrTessOuterIndex d
liftIO $ do
glUniform1f tli (fromIntegral tessFac)
glUniform1f tlo (fromIntegral tessFac)
withVBO map' ArrayBuffer $ do
vertexAttribPointer ci $= fgColorIndex
vertexAttribPointer ni $= fgNormalIndex
vertexAttribPointer vi $= fgVertexIndex
withVAA [ci,ni,vi] $ do
checkError "beforeDraw"
glPatchParameteri gl_PATCH_VERTICES 3
cullFace $= Just Front
polygonMode $= (Fill,Fill)
glDrawArrays gl_PATCHES 0 (fromIntegral numVert)
checkError "draw map"
-- set sample 1 as target in renderbuffer
{-framebufferRenderbuffer
DrawFramebuffer --write-only
(ColorAttachment 1) --sample 1
Renderbuffer --const
rb --buffer-}
mat44ToGPU :: L.M44 CFloat -> UniformLocation -> String -> IO ()
mat44ToGPU mat (UniformLocation dest) name = do
with (distribute mat) $ \ptr ->
glUniformMatrix4fv dest 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat)))
checkError $ "copy Matrix (" ++ name ++ ")"
mat33ToGPU :: L.M33 CFloat -> UniformLocation -> String -> IO ()
mat33ToGPU mat (UniformLocation dest) name = do
with (distribute mat) $ \ptr ->
glUniformMatrix3fv dest 1 0 (castPtr (ptr :: Ptr (L.M33 CFloat)))
checkError $ "copy Matrix (" ++ name ++ ")"
render :: Pioneers ()
render = do
-- -- FOO <<<<<<<<< denotes a stage (Shadowmap, Map, UI)
-- -- BAR --------- denotes a substage (which parts etc.)
-- -- BAZ denotes a sub-substage
state <- RWS.get
cam <- liftIO $ readTVarIO (state ^. camera)
let xa = cam ^. xAngle
ya = cam ^. yAngle
frust = cam ^. Types.frustum
camPos = cam ^. camObject
zDist' = cam ^. zDist
d = state ^. gl.glMap.mapShaderData
proj = shdrProjMatIndex d
nmat = shdrNormalMatIndex d
vmat = shdrViewMatIndex d
dmo = state ^. gl.glMap.mapObjectShaderData
projmo = shdrMOProjMatIndex dmo
nmatmo = shdrMONormalMatIndex dmo
vmatmo = shdrMOViewMatIndex dmo
suncam = getCam camPos 1 0.7 0 --TODO: Fix position of sun
sunnormal' = (case L.inv33 (fmap (^. L._xyz) suncam ^. L._xyz) of
(Just a) -> a
Nothing -> L.eye3) :: L.M33 CFloat
sunnmap = collect id sunnormal' :: L.M33 CFloat --transpose...
cam' = getCam camPos zDist' xa ya
normal' = (case L.inv33 (fmap (^. L._xyz) cam' ^. L._xyz) of
(Just a) -> a
Nothing -> L.eye3) :: L.M33 CFloat
nmap = collect id normal' :: L.M33 CFloat --transpose...
liftIO $ do
bindFramebuffer Framebuffer $= (state ^. gl.glFramebuffer)
{-bindRenderbuffer Renderbuffer $= (state ^. gl.glRenderbuffer)
framebufferRenderbuffer
Framebuffer
DepthAttachment
Renderbuffer
(state ^. gl.glRenderbuffer)-}
---- RENDER SHADOWMAP <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
{- liftIO $ do
textureBinding Texture2D $= Just (state ^. gl.glMap.shadowMapTexture)
framebufferTexture2D
Framebuffer
DepthAttachment
Texture2D
(state ^. gl.glMap.shadowMapTexture)
0
drawBuffer $= NoBuffers --color-buffer is not needed but must(?) be set up
checkError "setup Render-Target"
clear [DepthBuffer]
checkError "clearing shadowmap-buffer"
currentProgram $= Just (state ^. gl.glMap.mapProgram)
checkError "setting up shadowmap-program"
--set up projection (= copy from state)
--TODO: Fix width/depth
mat44ToGPU (createFrustumOrtho 20 20 0 100) proj "shadowmap-projection"
--set up camera
mat44ToGPU suncam vmat "shadowmap-cam"
--set up normal--Mat transpose((model*camera)^-1)
--TODO: needed?
mat33ToGPU sunnmap nmat "nmat"
-- drawMap
liftIO $ do
---- RENDER MAPOBJECTS --------------------------------------------
currentProgram $= Just (state ^. gl.glMap.objectProgram)
checkError "setting up shadowmap-program"
--set up projection (= copy from state)
--TODO: Fix width/depth
mat44ToGPU (createFrustumOrtho 20 20 0 100) projmo "shadowmap-projection"
--set up camera
--TODO: Fix magic constants... and camPos
mat44ToGPU suncam vmatmo "shadowmap-camera"
--set up normal--Mat transpose((model*camera)^-1)
--needed?
mat33ToGPU sunnmap nmatmo "nmat"
mapM_ renderObject (state ^. gl.glMap.mapObjects)
checkError "draw mapobjects"
checkError "draw ShadowMap"--}
---- RENDER MAP IN TEXTURE <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-- COLORMAP
liftIO $ do
{-bindFramebuffer Framebuffer $= defaultFramebufferObject
drawBuffer $= BackBuffers-}
tex <- readTVarIO (state ^. mapTexture)
dtex <- readTVarIO (state ^. mapDepthTexture)
-- add color to texture target
framebufferTexture2D
Framebuffer
(ColorAttachment 0)
Texture2D
tex
0
-- add depth to texture target
framebufferTexture2D
Framebuffer
DepthAttachment
Texture2D
dtex
0
-- Render to FrameBufferObject
drawBuffers $= [FBOColorAttachment 0]
checkError "setup Render-Target"
clear [ColorBuffer, DepthBuffer]
checkError "clear buffer"
currentProgram $= Just (state ^. gl.glMap.mapProgram)
checkError "setting up buffer"
--set up projection (= copy from state)
mat44ToGPU frust proj "projection"
--set up camera
mat44ToGPU cam' vmat "camera"
--set up normal--Mat transpose((model*camera)^-1)
mat33ToGPU nmap nmat "nmat"
drawMap
liftIO $ do
---- RENDER MAPOBJECTS --------------------------------------------
currentProgram $= Just (state ^. gl.glMap.objectProgram)
checkError "setting up shadowmap-program"
--set up projection (= copy from state)
mat44ToGPU frust projmo "mapObjects-projection"
--set up camera
mat44ToGPU cam' vmatmo "mapObjects-cam"
--set up normal
mat33ToGPU nmap nmatmo "mapObjects-nmat"
mapM_ renderObject (state ^. gl.glMap.mapObjects)
checkError "draw mapobjects"
---- COMPOSE RENDERING --------------------------------------------
-- Render to BackBuffer (=Screen)
bindFramebuffer Framebuffer $= defaultFramebufferObject
drawBuffer $= BackBuffers
-- Drawing HUD
clear [ColorBuffer, DepthBuffer]
checkError "clear buffer"
polygonMode $= (Fill,Fill)
let hud = state ^. gl.glHud
stride = fromIntegral $ sizeOf (undefined::GLfloat) * 2
vad = VertexArrayDescriptor 2 Float stride offset0
currentProgram $= Just (hud ^. hudProgram)
activeTexture $= TextureUnit 0
textureBinding Texture2D $= Just (hud ^. hudTexture)
uniform (hud ^. hudTexIndex) $= Index1 (0::GLint)
activeTexture $= TextureUnit 1
tex <- readTVarIO (state ^. mapTexture)
textureBinding Texture2D $= Just tex
uniform (hud ^. hudBackIndex) $= Index1 (1::GLint)
bindBuffer ArrayBuffer $= Just (hud ^. hudVBO)
vertexAttribPointer (hud ^. hudVertexIndex) $= (ToFloat, vad)
vertexAttribArray (hud ^. hudVertexIndex) $= Enabled
bindBuffer ElementArrayBuffer $= Just (hud ^. hudEBO)
drawElements TriangleStrip 4 UnsignedInt offset0
bindBuffer ArrayBuffer $= Nothing
bindBuffer ElementArrayBuffer $= Nothing

2
src/Render/RenderObject.hs Normal file
View File

@ -0,0 +1,2 @@
module Render.RenderObject where

97
src/Render/Types.hs Normal file
View File

@ -0,0 +1,97 @@
{-# LANGUAGE RankNTypes #-}
-- | Types specific to Rendering-Issues
module Render.Types (createFlatCam, createSphereCam, Camera, GLCamera(..)) where
import Linear
import Foreign.C (CFloat)
import Render.Misc (lookAt)
import Map.Map (giveMapHeight)
import Map.Types (PlayMap)
import GHC.Float
import qualified Debug.Trace as D
type Distance = Double
type Pitch = Double
type Yaw = Double
type Radius = Double
type Height = Double
-- | a Typclass for different Cameras
class GLCamera a where
-- | Gets the current Camera-Matrix for a given Cam, Distance Pitch and Yaw
getCam :: a -> Distance -> Pitch -> Yaw -> M44 CFloat
-- | Moves the Camera-Target on a projected 2D-plane
moveBy :: a -> (Position -> Position) -> PlayMap -> a
-- | Moves the Camera-Target to an absoloute position
move :: a -> Position -> PlayMap -> a
-- | Alias for a camera-position onto the 2d-plane it moves on
type Position = (Double, Double)
-- | Camera-Type. Either a Camera onto a 2D-flat-map or a spherical map
data Camera = Flat Position Height
| Sphere Position Radius
-- | create a Flatcam-Camera starting at given x/z-Coordinates
createFlatCam :: Double -> Double -> PlayMap -> Camera
createFlatCam x z map' = Flat (x,z) (giveMapHeight map' (x, z))
-- | create a Flatcam-Camera starting at given pitch/azimuth/radius
createSphereCam :: Double -> Double -> Double -> Camera
createSphereCam p a = Sphere (p,a)
-- | our Camera is indeed a GLCamera that we can use
--
-- TODO: Sphere-Cam still undefined
instance GLCamera Camera where
getCam (Flat (x',z') y') dist' xa' ya' =
lookAt (cpos ^+^ at') at' up
where
at' = V3 x (y+2) z
cpos = crot !* (V3 0 0 (-dist))
crot = (
(fromQuaternion $ axisAngle upmap (xa::CFloat))
!*!
(fromQuaternion $ axisAngle (V3 0 1 0) (ya::CFloat))
) ::M33 CFloat
upmap = ((fromQuaternion $ axisAngle (V3 0 1 0) (ya::CFloat)) :: M33 CFloat)
!* (V3 1 0 0)
x = realToFrac x'
y = realToFrac y'
z = realToFrac z'
dist = realToFrac dist'
xa = realToFrac xa'
ya = realToFrac ya'
up = V3 0 1 0
getCam (Sphere (inc',az') r') dist' xa' ya' = --inclination (pitch), azimuth (yaw)
lookAt (cpos ^+^ at') at' up
where
at' = sphereToCart (r+1) inc az
cpos = crot !* (V3 0 0 (-dist))
crot = (
(fromQuaternion $ axisAngle upmap (xa::CFloat))
!*!
(fromQuaternion $ axisAngle (V3 0 1 0) (ya::CFloat))
) ::M33 CFloat
upmap = ((fromQuaternion $ axisAngle (V3 0 1 0) (ya::CFloat)) :: M33 CFloat)
!* (V3 1 0 0)
up = (sphereToCart (r+1) inc az) ^-^ at'
r = realToFrac r'
inc = realToFrac inc'
az = realToFrac az'
dist = realToFrac dist'
xa = realToFrac xa'
ya = realToFrac ya'
moveBy (Sphere (inc, az) r) f map = undefined
moveBy (Flat (x', z') y) f map = Flat (x,z) y
where
(x,z) = f (x', z')
y = giveMapHeight map (x,z)
move c (x', z') map = moveBy c (\(x,z) -> (x+x',z+z')) map
-- | converting spherical to cartesian coordinates
sphereToCart :: (Floating a) => a -> a -> a -> V3 a
sphereToCart r inc az = V3
(r * (sin inc) * (cos az))
(r * (sin inc) * (sin az))
(r * (cos inc))

229
src/Types.hs Normal file
View File

@ -0,0 +1,229 @@
{-# LANGUAGE TemplateHaskell #-}
module Types where
import Control.Concurrent.STM (TQueue, TVar, readTVar, writeTVar, atomically)
import qualified Graphics.Rendering.OpenGL.GL as GL
import Graphics.UI.SDL as SDL (Event, Window)
import Foreign.C (CFloat)
import qualified Data.HashMap.Strict as Map
import Data.Time (UTCTime)
import Linear.Matrix (M44)
import Linear (V3)
import Control.Monad.RWS.Strict (RWST, liftIO, get)
import Control.Monad.Writer.Strict
--import Control.Monad (when)
import Control.Lens
import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject)
import Render.Types
import System.IO
import Importer.IQM.Types
import UI.UIBase
import Map.Types (PlayMap)
data Coord3D a = Coord3D a a a
--Static Read-Only-State
data Env = Env
{ _eventsChan :: TQueue Event
, _windowObject :: !Window
, _zDistClosest :: !Double
, _zDistFarthest :: !Double
--, envGLContext :: !GLContext
--, envFont :: TTF.TTFFont
-- , _renderer :: !Renderer
}
--Mutable State
data Position = Position
{ __x :: !Double
, __y :: !Double
}
data WindowState = WindowState
{ _width :: !Int
, _height :: !Int
, _shouldClose :: !Bool
}
data CameraState = CameraState
{ _xAngle :: !Double
, _yAngle :: !Double
, _zDist :: !Double
, _frustum :: !(M44 CFloat)
, _camObject :: !Camera
}
data IOState = IOState
{ _clock :: !UTCTime
, _tessClockFactor :: !Double
, _tessClockTime :: !UTCTime
}
data GameState = GameState
{ _currentMap :: !PlayMap
}
data ArrowKeyState = ArrowKeyState {
_up :: !Bool
,_down :: !Bool
,_left :: !Bool
,_right :: !Bool
}
data KeyboardState = KeyboardState
{ _arrowsPressed :: !ArrowKeyState
}
-- | State in which all map-related Data is stored
--
-- The map itself is rendered with mapProgram and the shaders given here directly
-- This does not include any objects on the map - only the map itself
--
-- _mapTextures must contain the following Textures (in this ordering) after initialisation:
--
-- 1. Grass
--
-- 2. Sand
--
-- 3. Water
--
-- 4. Stone
--
-- 5. Snow
--
-- 6. Dirt (blended on grass)
data GLMapState = GLMapState
{ _mapShaderData :: !MapShaderData
, _mapObjectShaderData :: !MapObjectShaderData
, _stateTessellationFactor :: !Int
, _stateMap :: !GL.BufferObject
, _mapVert :: !GL.NumArrayIndices
, _mapProgram :: !GL.Program
, _overviewTexture :: !TextureObject
, _shadowMapTexture :: !TextureObject
, _mapTextures :: ![TextureObject] --TODO: Fix size on list?
, _objectProgram :: !GL.Program
, _mapObjects :: ![MapObject]
, _shadowMapProgram :: !GL.Program
}
data MapShaderData = MapShaderData
{ shdrVertexIndex :: !GL.AttribLocation
, shdrColorIndex :: !GL.AttribLocation
, shdrNormalIndex :: !GL.AttribLocation
, shdrProjMatIndex :: !GL.UniformLocation
, shdrViewMatIndex :: !GL.UniformLocation
, shdrModelMatIndex :: !GL.UniformLocation
, shdrNormalMatIndex :: !GL.UniformLocation
, shdrTessInnerIndex :: !GL.UniformLocation
, shdrTessOuterIndex :: !GL.UniformLocation
}
data MapObjectShaderData = MapObjectShaderData
{ shdrMOVertexIndex :: !GL.AttribLocation
, shdrMOVertexOffsetIndex :: !GL.UniformLocation
, shdrMONormalIndex :: !GL.AttribLocation
, shdrMOTexIndex :: !GL.AttribLocation
, shdrMOProjMatIndex :: !GL.UniformLocation
, shdrMOViewMatIndex :: !GL.UniformLocation
, shdrMOModelMatIndex :: !GL.UniformLocation
, shdrMONormalMatIndex :: !GL.UniformLocation
, shdrMOTessInnerIndex :: !GL.UniformLocation
, shdrMOTessOuterIndex :: !GL.UniformLocation
}
data MapObject = MapObject !IQM !MapCoordinates !MapObjectState
data MapObjectState = MapObjectState ()
type MapCoordinates = V3 CFloat
data GLHud = GLHud
{ _hudTexture :: !TextureObject -- ^ HUD-Texture itself
, _hudTexIndex :: !GL.UniformLocation -- ^ Position of Overlay-Texture in Shader
, _hudBackIndex :: !GL.UniformLocation -- ^ Position of Background-Texture in Shader
, _hudVertexIndex :: !GL.AttribLocation -- ^ Position of Vertices in Shader
, _hudVert :: !GL.NumArrayIndices -- ^ Number of Vertices to draw
, _hudVBO :: !GL.BufferObject -- ^ Vertex-Buffer-Object
, _hudEBO :: !GL.BufferObject -- ^ Element-Buffer-Object
, _hudProgram :: !GL.Program -- ^ Program for rendering HUD
}
data GLState = GLState
{ _glMap :: !GLMapState
, _glHud :: !GLHud
, _glRenderbuffer :: !GL.RenderbufferObject
, _glFramebuffer :: !GL.FramebufferObject
}
data UIState = UIState
{ _uiHasChanged :: !Bool
, _uiMap :: Map.HashMap UIId (GUIWidget Pioneers)
, _uiObserverEvents :: Map.HashMap EventKey [EventHandler Pioneers]
, _uiRoots :: !([UIId])
, _uiButtonState :: !UIButtonState
}
data State = State
{ _window :: !WindowState
, _camera :: TVar CameraState
, _mapTexture :: TVar TextureObject
, _mapDepthTexture :: TVar TextureObject
, _camStack :: (Map.HashMap UIId (TVar CameraState, TVar TextureObject))
, _io :: !IOState
, _keyboard :: !KeyboardState
, _gl :: !GLState
, _game :: TVar GameState
, _ui :: !UIState
}
data Entry = Log {msg::String} deriving Eq
instance Show Entry where
show (Log s) = s
type Logger = WriterT [Entry] IO Handle
type Pioneers = RWST Env () State IO
-- when using TemplateHaskell order of declaration matters
$(makeLenses ''State)
$(makeLenses ''GLState)
$(makeLenses ''GLMapState)
$(makeLenses ''GLHud)
$(makeLenses ''KeyboardState)
$(makeLenses ''ArrowKeyState)
$(makeLenses ''GameState)
$(makeLenses ''IOState)
$(makeLenses ''CameraState)
$(makeLenses ''WindowState)
$(makeLenses ''Position)
$(makeLenses ''Env)
$(makeLenses ''UIState)
-- helper-functions for types
-- | atomically change gamestate on condition
changeIfGamestate :: (GameState -> Bool) -> (GameState -> GameState) -> Pioneers Bool
changeIfGamestate cond f = do
state <- get
liftIO $ atomically $ do
game' <- readTVar (state ^. game)
let cond' = cond game'
when cond' (writeTVar (state ^. game) (f game'))
return cond'
-- | atomically change gamestate
changeGamestate :: (GameState -> GameState) -> Pioneers ()
changeGamestate s = do
--forget implied result - is True anyway
_ <- changeIfGamestate (const True) s
return ()

323
src/UI/Callbacks.hs Normal file
View File

@ -0,0 +1,323 @@
{-# LANGUAGE DoAndIfThenElse #-}
module UI.Callbacks where
import qualified Graphics.Rendering.OpenGL.GL as GL
import Control.Lens ((^.), (.~), (%~), (^?), at, ix)
import Control.Monad (liftM, when, unless)
import Control.Monad.RWS.Strict (ask, get, modify)
import Control.Monad.Trans (liftIO)
import qualified Data.HashMap.Strict as Map
--import Data.List (foldl')
import Data.Maybe
import Foreign.Marshal.Array (pokeArray)
import Foreign.Marshal.Alloc (allocaBytes)
import qualified Graphics.UI.SDL as SDL
import Control.Concurrent.STM.TVar (readTVar, writeTVar)
import Control.Concurrent.STM (atomically)
import Render.Misc (curb,genColorData)
import Types
import UI.UIWidgets
import UI.UIOperations
-- TODO: define GUI positions in a file
createGUI :: ScreenUnit -> ScreenUnit -> UIState
createGUI w h = UIState
{ _uiHasChanged = True
, _uiMap = Map.fromList [ (UIId 0, createViewport (camera) LeftButton (0, 0, w, h) [UIId 1, UIId 2, UIId 5] 0) -- TODO: automatic resize
, (UIId 1, createContainer (30, 415, 100, 80) [] 1)
, (UIId 2, createPanel (50, 240, 0, 0) [UIId 3, UIId 4] 3)
, (UIId 3, createContainer (80, 15, 130, 90) [] 4 )
, (UIId 4, createButton (10, 40, 60, 130) 2 testMessage)
, (UIId 5, createViewport (camera) LeftButton (10, 10, 300, 200) [] 5) -- TODO: wrong camera
]
, _uiObserverEvents = Map.fromList [(WindowEvent, [resizeToScreenHandler (UIId 0)])]
, _uiRoots = [UIId 0]
, _uiButtonState = UIButtonState 0 Nothing False
}
getGUI :: Map.HashMap UIId (GUIWidget Pioneers) -> [GUIWidget Pioneers]
getGUI = Map.elems
{-# INLINE getGUI #-}
getRootIds :: Pioneers [UIId]
getRootIds = do
state <- get
return $ state ^. ui.uiRoots
getRoots :: Pioneers [GUIWidget Pioneers]
getRoots = do
state <- get
rootIds <- getRootIds
let hMap = state ^. ui.uiMap
return $ toGUIAnys hMap rootIds
testMessage :: MouseButton -> w -> Pixel -> Pioneers w
testMessage btn w (x, y) = do
case btn of
LeftButton -> liftIO $ putStrLn ("\tleft click on " ++ show x ++ "," ++ show y)
RightButton -> liftIO $ putStrLn ("\tright click on " ++ show x ++ "," ++ show y)
MiddleButton -> liftIO $ putStrLn ("\tmiddle click on " ++ show x ++ "," ++ show y)
MouseX1 -> liftIO $ putStrLn ("\tX1 click on " ++ show x ++ "," ++ show y)
MouseX2 -> liftIO $ putStrLn ("\tX2 click on " ++ show x ++ "," ++ show y)
return w
transformButton :: SDL.MouseButton -> Maybe MouseButton
transformButton SDL.LeftButton = Just LeftButton
transformButton SDL.RightButton = Just RightButton
transformButton SDL.MiddleButton = Just MiddleButton
transformButton SDL.MouseX1 = Just MouseX1
transformButton SDL.MouseX2 = Just MouseX2
transformButton _ = Nothing
eventCallback :: SDL.Event -> Pioneers ()
eventCallback e = do
env <- ask
case SDL.eventData e of
SDL.Window _ ev -> -- windowID event
case ev of
SDL.Resized (SDL.Size x y) -> windowResizeHandler x y
_ -> return ()
SDL.Keyboard movement _ _ key -> -- keyMovement windowID keyRepeat keySym
-- need modifiers? use "keyModifiers key" to get them
let aks = keyboard.arrowsPressed in
case SDL.keyScancode key of
SDL.R ->
liftIO $ do
r <- SDL.getRenderer $ env ^. windowObject
putStrLn $ unwords ["Renderer: ",show r]
SDL.Escape ->
modify $ window.shouldClose .~ True
SDL.Left ->
modify $ aks.left .~ (movement == SDL.KeyDown)
SDL.Right ->
modify $ aks.right .~ (movement == SDL.KeyDown)
SDL.Up ->
modify $ aks.up .~ (movement == SDL.KeyDown)
SDL.Down ->
modify $ aks.down .~ (movement == SDL.KeyDown)
SDL.KeypadPlus ->
when (movement == SDL.KeyDown) $ do
modify $ gl.glMap.stateTessellationFactor %~ (min 5) . (+1)
state <- get
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
SDL.KeypadMinus ->
when (movement == SDL.KeyDown) $ do
modify $ gl.glMap.stateTessellationFactor %~ (max 1) . (+(-1))
state <- get
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
_ ->
return ()
SDL.MouseMotion _ _ _ (SDL.Position x y) _ _ -> -- windowID mouseID motionState motionPosition xrel yrel
mouseMoveHandler (x, y)
SDL.MouseButton _ _ button state (SDL.Position x y) -> -- windowID mouseID button buttonState buttonAt
case state of
SDL.Pressed -> maybe (return ()) (`mousePressHandler` (x, y)) $ transformButton button
SDL.Released -> maybe (return ()) (`mouseReleaseHandler` (x, y)) $ transformButton button
--_ -> return () -- causes "pattern match overlapped"
SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll
do -- TODO: MouseWheelHandler
state <- get
liftIO $ atomically $ do
cam <- readTVar (state ^. camera)
let zDist' = (cam ^. zDist) + realToFrac (negate vscroll)
zDist'' = curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist'
cam' <- return $ zDist .~ zDist'' $ cam
writeTVar (state ^. camera) cam'
-- there is more (joystic, touchInterface, ...), but currently ignored
SDL.Quit -> modify $ window.shouldClose .~ True
_ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e]
windowResizeHandler :: ScreenUnit -> ScreenUnit -> Pioneers ()
windowResizeHandler x y = do
state <- get
case state ^. ui.uiObserverEvents.(at WindowEvent) of
Just evs -> let handle :: EventHandler Pioneers -> Pioneers (EventHandler Pioneers)
handle (WindowHandler h _) = h x y
handle h = return h -- TODO: may log invalid event mapping
in do newEvs <- mapM handle evs
modify $ ui.uiObserverEvents.(ix WindowEvent) .~ newEvs
Nothing -> return ()
mouseButtonHandler :: (WidgetEventHandler Pioneers -> MouseButton -> Pixel -> Bool -> GUIWidget Pioneers -> Pioneers (GUIWidget Pioneers))
-> MouseButton -> Pixel -> Pioneers ()
mouseButtonHandler transFunc btn px = do
state <- get
let hMap = state ^. ui.uiMap
currentWidget = state ^. ui.uiButtonState.mouseCurrentWidget
case currentWidget of
Just (wid, px') -> do
let target = toGUIAny hMap wid
target' <- case target ^. eventHandlers.(at MouseEvent) of
Just ma -> transFunc ma btn (px -: px') (state ^. ui.uiButtonState.mouseInside) target
Nothing -> return target
modify $ ui.uiMap %~ Map.insert wid target'
return ()
Nothing -> return ()
mousePressHandler :: MouseButton -> Pixel -> Pioneers ()
mousePressHandler btn px = do
modify $ ui.uiButtonState %~ (mousePressed %~ (+1)) -- TODO: what happens if released outside window? not reset properly?
mouseButtonHandler (\ma -> fromJust (ma ^? onMousePress)) btn px
mouseReleaseHandler :: MouseButton -> Pixel -> Pioneers ()
mouseReleaseHandler btn px = do
modify $ ui.uiButtonState %~ (mousePressed %~ flip (-) 1) -- TODO: what happens if pressed outside window? not set properly?
mouseButtonHandler (\ma -> fromJust (ma ^? onMouseRelease)) btn px
state <- get
unless (state ^. ui.uiButtonState.mousePressed > 0) $ do
case state ^. ui.uiButtonState.mouseCurrentWidget of
Just (wid, px') -> do
let target = toGUIAny (state ^. ui.uiMap) wid
-- debug
let short = target ^. baseProperties.shorthand
bound <- target ^. baseProperties.boundary
prio <- target ^. baseProperties.priority
liftIO $ putStrLn $ "releasing(" ++ show btn ++ ") " ++ short ++ ": " ++ show bound ++ " "
++ show prio ++ " at [" ++ show (fst px) ++ "," ++ show (snd px) ++ "]"
-- /debug
target' <- case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
Just ma -> do
target_ <- fromJust (ma ^? onMouseEnter) px' target -- TODO unsafe fromJust
fromJust (ma ^? onMouseMove) px' target_ -- TODO unsafe fromJust
Nothing -> return target
modify $ ui.uiMap %~ Map.insert wid target'
Nothing -> return ()
mouseSetMouseActive px -- TODO leave current
mouseSetMouseActiveTargeted :: (UIId, Pixel) -- ^ (target widget, local coorinates)
-> Pixel -- ^ global coordinates
-> Pioneers ()
mouseSetMouseActiveTargeted (wid, px') px = do
state <- get
--liftIO $ putStrLn $ "new target: " ++ show wid
let hMap = state ^. ui.uiMap
target = toGUIAny hMap wid
modify $ ui.uiButtonState %~ (mouseCurrentWidget .~ Just (wid, px -: px')) . (mouseInside .~ True)
target' <- case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
Just ma -> do
target_ <- fromJust (ma ^? onMouseEnter) px' target -- TODO unsafe fromJust
fromJust (ma ^? onMouseMove) px' target_ -- TODO unsafe fromJust
Nothing -> return target
modify $ ui.uiMap %~ Map.insert wid target'
mouseSetMouseActive :: Pixel -- ^global coordinates
-> Pioneers ()
mouseSetMouseActive px = do
roots <- getRootIds
hits <- liftM concat $ mapM (getInsideId px) roots
leading <- getLeadingWidget hits
case leading of
Just hit -> mouseSetMouseActiveTargeted hit px
Nothing -> modify $ ui.uiButtonState %~ (mouseCurrentWidget .~ Nothing) . (mouseInside .~ False)
mouseSetLeaving :: UIId -> Pixel -> Pioneers ()
mouseSetLeaving wid px = do
state <- get
let target = toGUIAny (state ^. ui.uiMap) wid
modify $ ui.uiButtonState.mouseInside .~ False
case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
Just ma -> do
target_ <- fromJust (ma ^? onMouseLeave) px target --TODO unsafe fromJust
target' <- if state ^. ui.uiButtonState.mousePressed <= 0 then return target_
else fromJust (ma ^? onMouseMove) px target_ --TODO unsafe fromJust
modify $ ui.uiMap %~ Map.insert wid target'
Nothing -> return ()
mouseMoveHandler :: Pixel -> Pioneers ()
mouseMoveHandler px = do
state <- get
--liftIO $ print $ state ^. ui.uiButtonState
case state ^. ui.uiButtonState.mouseCurrentWidget of -- existing mouse-active widget?
Just (wid, px') -> do
let target = toGUIAny (state ^. ui.uiMap) wid
inTest <- isHittingChild (px -: px') target
case inTest of
Left b -> -- no child hit
if b == state ^. ui.uiButtonState.mouseInside then -- > moving inside or outside
case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
Just ma -> do target' <- fromJust (ma ^? onMouseMove) (px -: px') target
modify $ ui.uiMap %~ Map.insert wid target'
Nothing -> return ()
else if b then -- && not mouseInside --> entering
do modify $ ui.uiButtonState.mouseInside .~ True
case target ^. eventHandlers.(at MouseMotionEvent) of --existing handler?
Just ma -> do
target_ <- fromJust (ma ^? onMouseEnter) (px -: px') target --TODO unsafe fromJust
target' <- fromJust (ma ^? onMouseMove) (px -: px') target_ --TODO unsafe fromJust
modify $ ui.uiMap %~ Map.insert wid target'
Nothing -> return ()
else -- not b && mouseInside --> leaving
do mouseSetLeaving wid (px -: px')
when (state ^. ui.uiButtonState.mousePressed <= 0) -- change mouse-active widget?
$ mouseSetMouseActive px
Right childHit -> do
mouseSetLeaving wid (px -: px')
when (state ^. ui.uiButtonState.mousePressed <= 0) -- change mouse-active widget?
$ mouseSetMouseActiveTargeted childHit px
Nothing -> do
mouseSetMouseActive px
-- | informs the GUI to prepare a blitting of state ^. gl.glHud.hudTexture
--
--TODO: should be done asynchronously at one point.
-- -> can't. if 2 Threads bind Textures its not sure
-- on which one the GPU will work.
-- "GL.textureBinding GL.Texture2D" is a State set
-- to the texture all following works on.
--
-- https://www.opengl.org/wiki/GLAPI/glTexSubImage2D for copy
prepareGUI :: Pioneers ()
prepareGUI = do
state <- get
roots <- getRoots
let tex = state ^. gl.glHud.hudTexture
liftIO $ do
-- bind texture - all later calls work on this one.
GL.textureBinding GL.Texture2D GL.$= Just tex
mapM_ (copyGUI tex (0, 0)) roots
modify $ ui.uiHasChanged .~ False
--TODO: Perform border-checking ... is xoff + width and yoff+height inside the screen-coordinates..
copyGUI :: GL.TextureObject -> Pixel -- ^current view’s offset
-> GUIWidget Pioneers -- ^the widget to draw
-> Pioneers ()
copyGUI tex (vX, vY) widget = do
(xoff, yoff, wWidth, wHeight) <- widget ^. baseProperties.boundary
state <- get
let
hMap = state ^. ui.uiMap
int = fromInteger.toInteger --conversion between Int8, GLInt, Int, ...
--temporary color here. lateron better some getData-function to
--get a list of pixel-data or a texture.
color = case widget ^. baseProperties.shorthand of
"VWP" -> [0,128,128,0]
"CNT" -> [255,0,0,128]
"BTN" -> [255,255,0,255]
"PNL" -> [128,128,128,128]
_ -> [255,0,255,255]
liftIO $ allocaBytes (wWidth*wHeight*4) $ \ptr -> do
--copy data into C-Array
pokeArray ptr (genColorData (wWidth*wHeight) color)
GL.texSubImage2D
GL.Texture2D
0
(GL.TexturePosition2D (int (vX + xoff)) (int (vY + yoff)))
(GL.TextureSize2D (int wWidth) (int wHeight))
(GL.PixelData GL.RGBA GL.UnsignedByte ptr)
prio <- widget ^. baseProperties.priority
when (widget ^. baseProperties.shorthand == "VWP" && prio == 5) $ do
-- copy camera texture on screen
return ()
nextChildrenIds <- widget ^. baseProperties.children
mapM_ (copyGUI tex (vX+xoff, vY+yoff)) $ toGUIAnys hMap nextChildrenIds
--TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc.
--TODO: Maybe queues are better?

22
src/UI/GUIOverlay.hs Normal file
View File

@ -0,0 +1,22 @@
module UI.GUIOverlay where
import Data.Int
import Graphics.UI.SDL.Surface
import Graphics.UI.SDL.Color
import Graphics.UI.SDL.Rect
import Graphics.UI.SDL.Types
import UI.UITypes
--createRGBSurface :: Int32 -> Int32 -> Int32 -> Word32 -> Word32 -> Word32 -> Word32 -> IO Surface
-- width height depth rFilter gFilter bFilter aFilter
-- createRGBSurface width height 32 0xFF000000 0x00FF0000 0x0000FF00 0x000000FF
updateGUI :: Int32 -> Int32 -> IO Surface
updateGUI width height = do
overlay <- createRGBSurface width height 32 0xFF000000 0x00FF0000 0x0000FF00 0x000000FF
fillRect overlay (Rect 10 10 400 300) (Color 255 0 128 255)
return overlay
--createTextureFromSurface :: Renderer -> Surface -> IO Texture
--createSoftwareRenderer :: Surface -> IO Renderer

417
src/UI/UIBase.hs Normal file
View File

@ -0,0 +1,417 @@
{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, DeriveGeneric, KindSignatures #-}
-- widget data is separated into several modules to avoid cyclic dependencies with the Type module
-- TODO: exclude UIMouseState constructor from export?
module UI.UIBase where
import Control.Lens ((^.), (.~), (%~), (&), ix, mapped, makeLenses)
import Control.Monad (join,liftM)
import Data.Array
import Data.Bits (xor)
import Data.Hashable
import qualified Data.HashMap.Strict as Map
import Data.Ix ()
-- import Data.Maybe
import GHC.Generics (Generic)
-- |Unit of screen/window
type ScreenUnit = Int
-- | @x@ and @y@ position on screen.
type Pixel = (ScreenUnit, ScreenUnit)
-- |Combines two tuples element-wise. Designed for use with 'Pixel'.
merge :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
merge f (x, y) (x', y') = (f x x', f y y')
{-# INLINABLE merge #-}
-- |Maps over the elements of a tuple. Designed for use with 'Pixel'.
(>:) :: (a -> b) -> (a, a) -> (b, b)
f >: (x, y) = (f x, f y)
{-# INLINABLE (>:) #-}
-- |Adds two numeric tuples component-wise.
(+:) :: (Num a) => (a, a) -> (a, a) -> (a, a)
(+:) = merge (+)
{-# INLINABLE (+:) #-}
-- |Calculates the component-wise difference between two tuples.
(-:) :: (Num a) => (a, a) -> (a, a) -> (a, a)
(-:) = merge (-)
{-# INLINABLE (-:) #-}
-- |Multiplies two numeric tuples component-wise.
(*:) :: (Num a) => (a, a) -> (a, a) -> (a, a)
(*:) = merge (*)
{-# INLINABLE (*:) #-}
infixl 7 *:
infixl 6 +:, -:
infixl 5 >:
-- |Id to reference a specific widget, must be unique.
newtype UIId = UIId Int deriving (Eq, Ord, Bounded, Ix, Hashable, Show, Read)
-- |Mouse buttons processed by the program.
data MouseButton = LeftButton | RightButton | MiddleButton | MouseX1 | MouseX2
deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
instance Hashable MouseButton where -- TODO: generic deriving creates functions that run forever
hash = fromEnum
hashWithSalt salt x = (salt * 16777619) `xor` hash x
---------------------------
--- widget state
---------------------------
-- |A key to reference a specific type of 'WidgetState'.
data WidgetStateKey = MouseStateKey | ViewportStateKey
deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
instance Hashable WidgetStateKey where -- TODO: generic deriving creates functions that run forever
hash = fromEnum
hashWithSalt salt x = (salt * 16777619) `xor` hash x
-- |Global tracking of mouse actions to determine event handling.
data UIButtonState = UIButtonState
{ _mousePressed :: Int -- ^amount of currently pressed buttons
, _mouseCurrentWidget :: Maybe (UIId, Pixel)
-- ^the current mouse-active widget and its global coordinates.
-- If @_mousePressed == 0@: widget the mouse is hovering over,
-- otherwise: widget the first button has been pressed on.
, _mouseInside :: Bool -- ^@True@ if the mouse is currently within the mouse-active widget
} deriving (Show, Eq)
-- |The button dependant state of a 'MouseState'.
data MouseButtonState = MouseButtonState
{ _mouseIsDragging :: Bool -- ^firing if pressed but not confirmed
, _mouseIsDeferred :: Bool
-- ^deferred if e. g. dragging but outside component
, _dragStart :: (ScreenUnit, ScreenUnit)
} deriving (Eq, Show)
-- |An applied state a widget may take, depending on its usage and event handlers. Corresponding Key: 'WidgetStateKey'.
data WidgetState =
-- |The state of a mouse reactive ui widget. Referenced by 'MouseStateKey'.
MouseState
{ _mouseStates :: Array MouseButton MouseButtonState
, _mouseIsReady :: Bool -- ^ready if mouse is above component
, _mousePixel :: Pixel -- ^current local position of the mouse, only updated if widget is the mouse-active component
}
|
-- |A position to store screen units. Referenced by 'ViewportStateKey'.
ViewportState
{ _isDragging :: Bool
, _dragStartX :: Double
, _dragStartY :: Double
, _dragAngleX :: Double
, _dragAngleY :: Double
}
deriving (Eq, Show)
---------------------------
--- events
---------------------------
-- |A key to reference a specific 'WidgetEventHandler'.
data WidgetEventKey = MouseEvent | MouseMotionEvent
deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
instance Hashable WidgetEventKey where -- TODO: generic deriving creates functions that run forever
hash = fromEnum
hashWithSalt salt x = (salt * 16777619) `xor` hash x
--- event handlers
-- |A handler to react on certain events. Corresponding key: 'WidgetEventKey'.
data WidgetEventHandler m =
-- |Handler to control the functionality of a 'GUIWidget' on mouse button events.
--
-- All screen coordinates are widget-local coordinates.
MouseHandler
{
-- |The function 'onMousePressed' is called when a button is pressed
-- while the button is mouse-active.
--
-- The boolean value indicates if the button press happened within the widget
-- ('_isInside').
--
-- The function returns the altered widget resulting from the button press.
_onMousePress :: MouseButton -> Pixel -> Bool -> GUIWidget m -> m (GUIWidget m)
,
-- |The function 'onMouseReleased' is called when a button is released
-- while the widget is mouse-active.
--
-- Thus, the mouse is either within the widget or outside while still dragging.
--
--
-- The boolean value indicates if the button release happened within the widget
-- ('_isInside').
--
-- The function returns the altered widget resulting from the button press.
_onMouseRelease :: MouseButton -> Pixel -> Bool -> GUIWidget m -> m (GUIWidget m)
}
|
-- |Handler to control the functionality of a 'GUIWidget' on mouse movement.
--
-- All screen coordinates are widget-local coordinates.
MouseMotionHandler
{
-- |The function 'onMouseMove' is invoked when the mouse is moved inside the
-- widget’s extent ('isInside') while no button is pressed or when the mouse is inside the
-- widget’s extent while another button loses its mouse-active state. Triggered after
-- '_onMouseEnter' or '_onMouseLeave' (only if still mouse-active on leaving) if applicable.
--
-- The function returns the altered widget resulting from the button press.
_onMouseMove :: Pixel -> GUIWidget m -> m (GUIWidget m)
,
-- |The function 'onMouseMove' is invoked when the mouse enters the
-- widget’s extent ('isInside') or when the mouse is inside the
-- widget’s extent while another button loses its mouse-active state.
--
-- The function returns the altered widget resulting from the button press.
_onMouseEnter :: Pixel -> GUIWidget m -> m (GUIWidget m)
,
-- |The function 'onMouseLeave' is invoked when the mouse leaves the
-- widget’s extent ('isInside') while no other widget is mouse-active.
--
-- The function returns the altered widget resulting from the button press.
_onMouseLeave :: Pixel -> GUIWidget m -> m (GUIWidget m)
}
deriving ()
-- |A key to reference a specific 'EventHandler'.
data EventKey = WindowEvent | WidgetPositionEvent
deriving (Eq, Ord, Enum, Ix, Bounded, Generic, Show, Read)
instance Hashable EventKey where -- TODO: generic deriving creates functions that run forever
hash = fromEnum
hashWithSalt salt x = (salt * 16777619) `xor` hash x
-- |A handler to react on certain events. Corresponding key: 'EventKey'.
data EventHandler (m :: * -> *) =
WindowHandler
{
-- |The function '_onWindowResize' is invoked when the global application window changes size.
--
-- The input is the window’s new width and height in that order.
--
-- The returned handler is resulting handler that may change by the event. Its type must
-- remain @WindowHandler@.
_onWindowResize :: ScreenUnit -> ScreenUnit -> m (EventHandler m)
,
-- |Unique id to identify an event instance.
_eventId :: UIId
}
instance Eq (EventHandler m) where
WindowHandler _ id' == WindowHandler _ id'' = id' == id''
_ == _ = False
---------------------------
--- widgets
---------------------------
-- |A @GUIWidget@ is a visual object the HUD is composed of.
data GUIWidget m = Widget
{_baseProperties :: GUIBaseProperties m
,_graphics :: GUIGraphics m
,_widgetStates :: Map.HashMap WidgetStateKey WidgetState -- TODO? unsave mapping
,_eventHandlers :: Map.HashMap WidgetEventKey (WidgetEventHandler m) -- no guarantee that data match key
}
-- |Base properties are fundamental settings of any 'GUIWidget'.
-- They mostly control positioning and widget hierarchy.
data GUIBaseProperties m = BaseProperties
{
-- |The @_getBoundary@ function gives the outer extents of the @GUIWidget@.
-- The bounding box wholly contains all children components.
_boundary :: m (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -- ^@(x, y, width, height)@ in pixels (screen coordinates)
,
-- |The @_getChildren@ function returns all children associated with this widget.
--
-- All children must be wholly inside the parent’s bounding box specified by '_boundary'.
_children :: m [UIId]
,
-- |The function @_isInside@ tests whether a point is inside the widget itself.
-- A screen position may be inside the bounding box of a widget but not considered part of the
-- component.
--
-- The default implementations tests if the point is within the rectangle specified by the
-- 'getBoundary' function.
--
-- The passed coordinates are widget-local coordinates.
_isInside :: GUIWidget m -> Pixel -> m Bool
,
-- |The @_getPriority@ function returns the priority score of a @GUIWidget@.
-- A widget with a high score is more in the front than a low scored widget.
_priority :: m Int
,
-- |The @_getShorthand@ function returns a descriptive 'String' mainly for debuggin prupose.
-- The shorthand should be unique for each instance.
_shorthand :: String
}
-- |@GUIGraphics@ functions define the look of a 'GUIWidget'.
data GUIGraphics (m :: * -> *) = Graphics
$(makeLenses ''UIButtonState)
$(makeLenses ''WidgetState)
$(makeLenses ''MouseButtonState)
$(makeLenses ''WidgetEventHandler)
$(makeLenses ''GUIWidget)
$(makeLenses ''GUIBaseProperties)
$(makeLenses ''GUIGraphics)
initialViewportState :: WidgetState
initialViewportState = ViewportState False 0 0 0 0
-- |Creates a default @MouseButtonState@.
initialButtonState :: MouseButtonState
initialButtonState = MouseButtonState False False (0, 0)
{-# INLINE initialButtonState #-}
-- |Creates a 'MouseState' its @_mouseStates@ are valid 'MouseButtonState's for any 'MouseButton'.
initialMouseState :: WidgetState
initialMouseState = MouseState (array (minBound, maxBound) [(i, initialButtonState) | i <- range (minBound, maxBound)])
False (0, 0)
{-# INLINE initialMouseState #-}
-- |The function 'combinedMouseHandler' creates a 'MouseHandler' by composing the action functions
-- of two handlers. Thereby, the resulting widget of the first handler is the input widget of the
-- second handler and all other parameters are the same for both function calls.
--
-- If not both input handlers are of type @MouseHandler@ an error is raised.
combinedMouseHandler :: (Monad m) => WidgetEventHandler m -> WidgetEventHandler m -> WidgetEventHandler m
combinedMouseHandler (MouseHandler p1 r1) (MouseHandler p2 r2) =
MouseHandler (comb p1 p2) (comb r1 r2)
where comb h1 h2 btn px inside = join . liftM (h2 btn px inside) . h1 btn px inside
combinedMouseHandler _ _ = error $ "combineMouseHandler can only combine two WidgetEventHandler" ++
" with constructor MouseHandler"
-- |The function 'combinedMouseMotionHandler' creates a 'MouseHandler' by composing the action
-- functions of two handlers. Thereby, the resulting widget of the second handler is the input
-- widget of the second handler and all other parameters are the same for both function calls.
--
-- If not both input handlers are of type @MouseMotionHandler@ an error is raised.
combinedMouseMotionHandler :: (Monad m) => WidgetEventHandler m -> WidgetEventHandler m -> WidgetEventHandler m
combinedMouseMotionHandler (MouseMotionHandler m1 e1 l1) (MouseMotionHandler m2 e2 l2) =
MouseMotionHandler (comb m1 m2) (comb e1 e2) (comb l1 l2)
where comb h1 h2 px = join . liftM (h2 px) . h1 px
combinedMouseMotionHandler _ _ = error $ "combineMouseMotionHandler can only combine two WidgetEventHandler" ++
" with constructor MouseMotionHandler"
-- |The function 'emptyMouseHandler' creates a 'MouseHandler' that does nothing.
-- It may be useful as construction kit.
--
-- >>> emptyMouseHandler & _onMousePress .~ myPressFunction
-- >>> emptyMouseHandler { _onMousePress = myPressFunction }
emptyMouseHandler :: (Monad m) => WidgetEventHandler m
emptyMouseHandler = MouseHandler (\_ _ _ -> return) (\_ _ _ -> return)
-- |The function 'emptyMouseMotionHandler' creates a 'MouseMotionHandler' that does nothing.
-- It may be useful as construction kit.
--
-- >>> emptyMouseMotionHandler & _onMouseMove .~ myMoveFunction
-- >>> emptyMouseHandler { _onMouseMove = myMoveFunction }
emptyMouseMotionHandler :: (Monad m) => WidgetEventHandler m
emptyMouseMotionHandler = MouseMotionHandler (const return) (const return) (const return)
-- TODO? breaks if button array not of sufficient size -- will be avoided by excluding constructor export
-- |Creates a 'MouseHandler' that sets a widget’s 'MouseButtonState' properties if present,
-- only fully functional in conjunction with 'setMouseMotionStateActions'.
setMouseStateActions :: (Monad m) => WidgetEventHandler m
setMouseStateActions = MouseHandler press' release'
where
-- |Change 'MouseButtonState'’s '_mouseIsDragging' to @True@.
press' b _ _ w =
return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b).mouseIsDragging .~ True
-- |Change 'MouseButtonState'’s '_mouseIsDragging' and '_mouseIsDeferred' to @False@.
release' b _ _ w =
return $ w & widgetStates.(ix MouseStateKey).mouseStates.(ix b) %~
(mouseIsDragging .~ False) . (mouseIsDeferred .~ False)
-- |Creates a 'MouseHandler' that sets a widget’s 'MouseState' properties if present,
-- only fully functional in conjunction with 'setMouseStateActions'.
setMouseMotionStateActions :: (Monad m) => WidgetEventHandler m
setMouseMotionStateActions = MouseMotionHandler move' enter' leave'
where
-- |Updates mouse position.
move' p w = return $ w & widgetStates.(ix MouseStateKey).mousePixel .~ p
-- |Sets '_mouseIsReady' to @True@, changes '_mouseIsDeferred' to '_mouseIsDragging'’s current
-- value and sets '_mouseIsDragging' to @False@.
enter' p w = return $ w & widgetStates.(ix MouseStateKey)
%~ (mouseIsReady .~ True) . (mousePixel .~ p)
. (mouseStates.mapped %~ (mouseIsDeferred .~ False)
-- following line executed BEFORE above line
. (\sState -> sState & mouseIsDragging .~ not (sState ^. mouseIsDeferred)))
-- |Sets '_mouseIsReady' to @False@, changes '_mouseIsDragging' to '_mouseIsDeferred'’s current
-- value and sets '_mouseIsDeferred' to @False@.
leave' p w = return $ w & widgetStates.(ix MouseStateKey)
%~ (mouseIsReady .~ False) . (mousePixel .~ p)
. (mouseStates.mapped %~ (mouseIsDragging .~ False)
-- following line executed BEFORE above line
. (\sState -> sState & mouseIsDeferred .~ not (sState ^. mouseIsDragging)))
-- TODO: make only fire if press started within widget
-- |Creates a 'MouseHandler' that reacts on mouse clicks.
--
-- Does /not/ update the widget’s 'MouseState'!
buttonMouseActions :: (Monad m) => (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press
-> WidgetEventHandler m
buttonMouseActions a = MouseHandler press' release'
where
press' _ _ _ = return
release' b p inside w = if inside then a b w p else return w
-- TODO: make only fire if press started within widget
-- |Creates a 'MouseHandler' that reacts on mouse clicks.
--
-- Does /not/ update the widget’s 'MouseState'!
buttonSingleMouseActions :: (Monad m) => (GUIWidget m -> Pixel -> m (GUIWidget m)) -- ^action on button press
-> MouseButton -> WidgetEventHandler m
buttonSingleMouseActions a btn = MouseHandler press' release'
where
press' _ _ _ = return
release' b p inside w = if inside && b == btn then a w p else return w
emptyGraphics :: (Monad m) => GUIGraphics m
emptyGraphics = Graphics
-- |Extracts width and height from a '_boundary' property of a 'GUIBaseProperties'.
extractExtent :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> (ScreenUnit, ScreenUnit)
extractExtent (_,_,w,h) = (w,h)
{-# INLINABLE extractExtent #-}
-- |Calculates whether a point’s value exceed the given width and height.
isInsideExtent :: (ScreenUnit, ScreenUnit) -> Pixel -> Bool
isInsideExtent (w,h) (x',y') = (x' <= w) && (x' >= 0) && (y' <= h) && (y' >= 0)
-- |Calculates whether a point is within a given rectangle.
isInsideRect :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> Pixel -> Bool
isInsideRect (x,y,w,h) px = isInsideExtent (w, h) $ px -: (x, y)
-- |@GUIBaseProperties@ with a rectangular base that fills the bounds.
rectangularBase :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> String -> GUIBaseProperties m
rectangularBase bnd chld prio short =
BaseProperties (return bnd) (return chld)
(\w p -> liftM (flip isInsideExtent p . extractExtent) (w ^. baseProperties.boundary)) -- isInside
(return prio) short
debugShowWidget' :: (Monad m) => GUIWidget m -> m String
debugShowWidget' (Widget base _ _ handler) = do
bnd <- base ^. boundary
chld <- base ^. children
prio <- base ^. priority
let short = base ^. shorthand
return $ concat [short,"| boundary:", show bnd, ", children:", show chld,
",priority:",show prio, maybe "" (const ", with mouse handler") (Map.lookup MouseEvent handler)]

122
src/UI/UIOperations.hs Normal file
View File

@ -0,0 +1,122 @@
module UI.UIOperations where
import Control.Lens ((^.), (%~))
import Control.Monad (liftM)
--import Control.Monad.IO.Class (liftIO)
import Control.Monad.RWS.Strict (get, modify)
import qualified Data.HashMap.Strict as Map
import Data.Hashable
--import qualified Data.List as L
import Data.Maybe
import Types
import UI.UIBase
-- TODO: test GUI function to scan for overlapping widgets
toGUIAny :: Map.HashMap UIId (GUIWidget m) -> UIId -> GUIWidget m -- TODO: what to do if widget not inside map -> inconsistent state
toGUIAny m uid = fromMaybe (error "map does not contain requested key") (Map.lookup uid m)
{-# INLINABLE toGUIAny #-}
toGUIAnys :: Map.HashMap UIId (GUIWidget m) -> [UIId] -> [GUIWidget m]
toGUIAnys m = mapMaybe (`Map.lookup` m)
{-# INLINABLE toGUIAnys #-}
-- TODO: check for missing components?
-- | Tests whether a point is inside a widget by testing its bounding box first.
isInsideFast :: Monad m => GUIWidget m
-> Pixel -- ^ local coordinates
-> m Bool
isInsideFast wg px = do
(_, _, w, h) <- wg ^. baseProperties.boundary
liftM (isInsideExtent (w, h) px &&) $ (wg ^. baseProperties.isInside) wg px
-- |Adds an event to the given map. The new event is concatenated to present events. Does not test
-- if the map already contains the given element.
addEvent :: (Eq k, Hashable k) => k -> v -> Map.HashMap k [v] -> Map.HashMap k [v]
addEvent k v eventMap = Map.insertWith (++) k [v] eventMap
-- |Adds an event to the global event map such that the event handler will be notified on occurrance.
registerEvent :: EventKey -> EventHandler Pioneers -> Pioneers ()
registerEvent k v = modify $ ui.uiObserverEvents %~ addEvent k v
-- |The 'deleteQualitative' function behaves like 'Data.List.deleteBy' but reports @True@ if the
-- list contained the relevant object.
deleteQualitative :: (a -> a -> Bool) -> a -> [a] -> ([a], Bool)
deleteQualitative _ _ [] = ([], False)
deleteQualitative eq x (y:ys) = if x `eq` y then (ys, True) else
let (zs, b) = deleteQualitative eq x ys
in (y:zs, b)
-- |Removes the first occurrence of an event from the given map if it is within the event list of
-- the key.
removeEvent :: (Eq k, Hashable k, Eq v) => k -> v -> Map.HashMap k [v] -> Map.HashMap k [v]
removeEvent k v eventMap =
case Map.lookup k eventMap of
Just list -> case deleteQualitative (==) v list of
(_, False) -> eventMap
(ys, _) -> case ys of
[] -> Map.delete k eventMap
_ -> Map.insert k ys eventMap
Nothing -> Map.insert k [v] eventMap
-- |Adds an event to the global event map such that the event handler will be notified on occurrance.
deregisterEvent :: EventKey -> EventHandler Pioneers -> Pioneers ()
deregisterEvent k v = modify $ ui.uiObserverEvents %~ removeEvent k v
-- |The function 'getInsideId' returns child widgets that overlap with a
-- specific screen position and the pixel’s local coordinates.
--
-- A screen position may be inside the bounding box of a widget but not
-- considered part of the component. The function returns all hit widgets that
-- have no hit children, which may be the input widget itself,
-- or @[]@ if the point does not hit the widget.
getInsideId :: Pixel -- ^parent’s local coordinates
-> UIId -- ^the parent widget
-> Pioneers [(UIId, Pixel)]
getInsideId px uid = do
state <- get
let wg = toGUIAny (state ^. ui.uiMap) uid
(bX, bY, _, _) <- wg ^. baseProperties.boundary
let px' = px -: (bX, bY)
inside <- isInsideFast wg px'
if inside -- test inside parent’s bounding box
then do
childrenIds <- wg ^. baseProperties.children
hitChildren <- liftM concat $ mapM (getInsideId px') childrenIds
case hitChildren of
[] -> return [(uid, px')]
_ -> return hitChildren
else return []
--TODO: Priority queue?
--TODO: only needs to return single target if non-overlapping-child convention applies
-- TODO not needed if non-overlapping-child convention applies
getLeadingWidget :: [(UIId, Pixel)] -- ^widgets and their screen positions
-> Pioneers (Maybe (UIId, Pixel)) -- ^the leading widget
getLeadingWidget [] = return Nothing
getLeadingWidget (x:_) = return $ Just x
-- |The function 'isHittingChild' tests if a pixel is hitting a child of the given widget.
--
-- @'Left' 'False'@ is returned if the point is outside the widget,
-- @'Left' 'True'@ is returned if the point is inside the widget and hits no child and
-- 'Right' in combination with both the innermost hit child and the position’s local coordinates
-- is returned otherwise.
isHittingChild :: Pixel -- ^parent’s local coordinates
-> GUIWidget Pioneers -- ^parent widget
-> Pioneers (Either Bool (UIId, Pixel))
isHittingChild px wg = do
isIn <- isInsideFast wg px
if isIn
then do
chld <- wg ^. baseProperties.children
hitChld <- liftM concat $ mapM (getInsideId px) chld
hitLead <- getLeadingWidget hitChld
case hitLead of
Nothing -> return $ Left True
Just h -> return $ Right h
else return $ Left False

129
src/UI/UIWidgets.hs Normal file
View File

@ -0,0 +1,129 @@
{-# LANGUAGE InstanceSigs, MultiParamTypeClasses, FlexibleInstances #-}
module UI.UIWidgets (module UI.UIWidgets, module UI.UIBase) where
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar (readTVarIO, writeTVar, TVar())
import Control.Lens ((^.), (.~), (%~), (&), (^?), at, Getting())
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import Control.Monad.RWS.Strict (get, modify)
import Data.List
import Data.Maybe
import qualified Data.HashMap.Strict as Map
import Types
import Render.Misc (curb)
import UI.UIBase
import UI.UIOperations
createContainer :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget m
createContainer bnd chld prio = Widget (rectangularBase bnd chld prio "CNT")
emptyGraphics
Map.empty -- widget states
Map.empty -- event handlers
createPanel :: (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget Pioneers
createPanel bnd chld prio = Widget (rectangularBase bnd chld prio "PNL" & boundary .~ autosize')
emptyGraphics
Map.empty -- widget states
Map.empty -- event handlers
where
autosize' :: Pioneers (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit)
autosize' = do
state <- get
let hmap = state ^. ui . uiMap
determineSize' :: (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit) -> (ScreenUnit, ScreenUnit, ScreenUnit ,ScreenUnit)
determineSize' (x, y, w, h) (x', y', w', h') = (x, y, max w (x' + w'), max h (y' + h'))
case chld of
[] -> return bnd
cs -> do let widgets = mapMaybe (`Map.lookup` hmap) cs
foldl' (liftM2 determineSize') (return bnd) $ map (\w -> w ^. baseProperties.boundary) widgets
createButton :: (Monad m) => (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> Int -> (MouseButton -> GUIWidget m -> Pixel -> m (GUIWidget m)) -> GUIWidget m
createButton bnd prio action = Widget (rectangularBase bnd [] prio "BTN")
emptyGraphics
(Map.fromList [(MouseStateKey, initialMouseState)]) -- widget states
(Map.fromList [(MouseEvent, buttonMouseActions action)]) -- event handlers
createViewport :: Getting (TVar CameraState) State (TVar CameraState)
--Setting (->) State State (TVar CameraState) (TVar CameraState) -- ^ lens to connected @TVar CameraState@
-> MouseButton -- ^ button to drag with
-> (ScreenUnit, ScreenUnit, ScreenUnit, ScreenUnit) -> [UIId] -> Int -> GUIWidget Pioneers
createViewport thelens btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP")
emptyGraphics
(Map.fromList [(ViewportStateKey, initialViewportState)]) -- widget states
(Map.fromList [(MouseEvent, viewportMouseAction)
,(MouseMotionEvent, viewportMouseMotionAction)]) -- event handlers
where
updateCamera :: Double -> Double -> Double -> Double -> Double -> Double -> CameraState -> CameraState
updateCamera xStart' yStart' x y sodxa sodya cam =
let myrot = (x - xStart') / 2
mxrot = (y - yStart') / 2
newXAngle' = sodxa + mxrot/100
newXAngle = curb (pi/12) (0.45*pi) newXAngle'
newYAngle' = sodya + myrot/100
newYAngle
| newYAngle' > pi = newYAngle' - 2 * pi
| newYAngle' < (-pi) = newYAngle' + 2 * pi
| otherwise = newYAngle'
in cam & (xAngle .~ newXAngle) . (yAngle .~ newYAngle)
viewportMouseAction :: WidgetEventHandler Pioneers
viewportMouseAction =
let press btn' (x, y) _ w =
do if (btn == btn')
then do state <- get
let camT = state ^. thelens
cam <- liftIO $ readTVarIO camT
let sodxa = cam ^. xAngle
sodya = cam ^. yAngle
liftIO $ atomically $ writeTVar camT $
updateCamera (fromIntegral x) (fromIntegral y) (fromIntegral x) (fromIntegral y) sodxa sodya cam
return $ w & widgetStates . at ViewportStateKey .~
Just (ViewportState True (fromIntegral x) (fromIntegral y) sodxa sodya)
else return w
release btn' _ _ w = if (btn' == btn)
then
-- modify ViewportState to "not dragging" or recreate ViewportState state if not present
return $ w & widgetStates . at ViewportStateKey %~
maybe (Just $ initialViewportState) (\s -> Just (s & isDragging .~ False))
else return w
in MouseHandler press release
viewportMouseMotionAction :: WidgetEventHandler Pioneers
viewportMouseMotionAction =
let move (x, y) w =
do let mbPosState = w ^. widgetStates.(at ViewportStateKey)
case mbPosState of
Just posState ->
when (maybe False id (posState ^? isDragging)) $ do
state <- get
let camT = state ^. thelens
cam <- liftIO $ readTVarIO camT
let xS = fromJust $ posState ^? dragStartX -- fromJust is safe
yS = fromJust $ posState ^? dragStartY -- fromJust is safe
sodxa = fromJust $ posState ^? dragAngleX -- fromJust is safe
sodya = fromJust $ posState ^? dragAngleY -- fromJust is safe
liftIO $ atomically $ writeTVar camT $
updateCamera xS yS (fromIntegral x) (fromIntegral y) sodxa sodya cam
Nothing -> return ()
return w
in emptyMouseMotionHandler & onMouseMove .~ move
resizeToScreenHandler :: UIId -- ^id of a widget
-> EventHandler Pioneers
resizeToScreenHandler id' = WindowHandler resize (UIId 0) -- TODO: unique id
where resize :: ScreenUnit -> ScreenUnit -> Pioneers (EventHandler Pioneers)
resize w h = do
state <- get
let wg = toGUIAny (state ^. ui.uiMap) id'
(x, y, _, _) <- wg ^. baseProperties.boundary
let wg' = wg & baseProperties.boundary .~ return (x, y, w-x, h-y)
modify $ ui.uiMap %~ Map.insert id' wg'
return $ WindowHandler resize (UIId 0)

226
stylesheets/print.css
View File

@ -1,226 +0,0 @@
html, body, div, span, applet, object, iframe,
h1, h2, h3, h4, h5, h6, p, blockquote, pre,
a, abbr, acronym, address, big, cite, code,
del, dfn, em, img, ins, kbd, q, s, samp,
small, strike, strong, sub, sup, tt, var,
b, u, i, center,
dl, dt, dd, ol, ul, li,
fieldset, form, label, legend,
table, caption, tbody, tfoot, thead, tr, th, td,
article, aside, canvas, details, embed,
figure, figcaption, footer, header, hgroup,
menu, nav, output, ruby, section, summary,
time, mark, audio, video {
margin: 0;
padding: 0;
border: 0;
font-size: 100%;
font: inherit;
vertical-align: baseline;
}
/* HTML5 display-role reset for older browsers */
article, aside, details, figcaption, figure,
footer, header, hgroup, menu, nav, section {
display: block;
}
body {
line-height: 1;
}
ol, ul {
list-style: none;
}
blockquote, q {
quotes: none;
}
blockquote:before, blockquote:after,
q:before, q:after {
content: '';
content: none;
}
table {
border-collapse: collapse;
border-spacing: 0;
}
body {
font-size: 13px;
line-height: 1.5;
font-family: 'Helvetica Neue', Helvetica, Arial, serif;
color: #000;
}
a {
color: #d5000d;
font-weight: bold;
}
header {
padding-top: 35px;
padding-bottom: 10px;
}
header h1 {
font-weight: bold;
letter-spacing: -1px;
font-size: 48px;
color: #303030;
line-height: 1.2;
}
header h2 {
letter-spacing: -1px;
font-size: 24px;
color: #aaa;
font-weight: normal;
line-height: 1.3;
}
#downloads {
display: none;
}
#main_content {
padding-top: 20px;
}
code, pre {
font-family: Monaco, "Bitstream Vera Sans Mono", "Lucida Console", Terminal;
color: #222;
margin-bottom: 30px;
font-size: 12px;
}
code {
padding: 0 3px;
}
pre {
border: solid 1px #ddd;
padding: 20px;
overflow: auto;
}
pre code {
padding: 0;
}
ul, ol, dl {
margin-bottom: 20px;
}
/* COMMON STYLES */
table {
width: 100%;
border: 1px solid #ebebeb;
}
th {
font-weight: 500;
}
td {
border: 1px solid #ebebeb;
text-align: center;
font-weight: 300;
}
form {
background: #f2f2f2;
padding: 20px;
}
/* GENERAL ELEMENT TYPE STYLES */
h1 {
font-size: 2.8em;
}
h2 {
font-size: 22px;
font-weight: bold;
color: #303030;
margin-bottom: 8px;
}
h3 {
color: #d5000d;
font-size: 18px;
font-weight: bold;
margin-bottom: 8px;
}
h4 {
font-size: 16px;
color: #303030;
font-weight: bold;
}
h5 {
font-size: 1em;
color: #303030;
}
h6 {
font-size: .8em;
color: #303030;
}
p {
font-weight: 300;
margin-bottom: 20px;
}
a {
text-decoration: none;
}
p a {
font-weight: 400;
}
blockquote {
font-size: 1.6em;
border-left: 10px solid #e9e9e9;
margin-bottom: 20px;
padding: 0 0 0 30px;
}
ul li {
list-style: disc inside;
padding-left: 20px;
}
ol li {
list-style: decimal inside;
padding-left: 3px;
}
dl dd {
font-style: italic;
font-weight: 100;
}
footer {
margin-top: 40px;
padding-top: 20px;
padding-bottom: 30px;
font-size: 13px;
color: #aaa;
}
footer a {
color: #666;
}
/* MISC */
.clearfix:after {
clear: both;
content: '.';
display: block;
visibility: hidden;
height: 0;
}
.clearfix {display: inline-block;}
* html .clearfix {height: 1%;}
.clearfix {display: block;}

69
stylesheets/pygment_trac.css
View File

@ -1,69 +0,0 @@
.highlight { background: #ffffff; }
.highlight .c { color: #999988; font-style: italic } /* Comment */
.highlight .err { color: #a61717; background-color: #e3d2d2 } /* Error */
.highlight .k { font-weight: bold } /* Keyword */
.highlight .o { font-weight: bold } /* Operator */
.highlight .cm { color: #999988; font-style: italic } /* Comment.Multiline */
.highlight .cp { color: #999999; font-weight: bold } /* Comment.Preproc */
.highlight .c1 { color: #999988; font-style: italic } /* Comment.Single */
.highlight .cs { color: #999999; font-weight: bold; font-style: italic } /* Comment.Special */
.highlight .gd { color: #000000; background-color: #ffdddd } /* Generic.Deleted */
.highlight .gd .x { color: #000000; background-color: #ffaaaa } /* Generic.Deleted.Specific */
.highlight .ge { font-style: italic } /* Generic.Emph */
.highlight .gr { color: #aa0000 } /* Generic.Error */
.highlight .gh { color: #999999 } /* Generic.Heading */
.highlight .gi { color: #000000; background-color: #ddffdd } /* Generic.Inserted */
.highlight .gi .x { color: #000000; background-color: #aaffaa } /* Generic.Inserted.Specific */
.highlight .go { color: #888888 } /* Generic.Output */
.highlight .gp { color: #555555 } /* Generic.Prompt */
.highlight .gs { font-weight: bold } /* Generic.Strong */
.highlight .gu { color: #800080; font-weight: bold; } /* Generic.Subheading */
.highlight .gt { color: #aa0000 } /* Generic.Traceback */
.highlight .kc { font-weight: bold } /* Keyword.Constant */
.highlight .kd { font-weight: bold } /* Keyword.Declaration */
.highlight .kn { font-weight: bold } /* Keyword.Namespace */
.highlight .kp { font-weight: bold } /* Keyword.Pseudo */
.highlight .kr { font-weight: bold } /* Keyword.Reserved */
.highlight .kt { color: #445588; font-weight: bold } /* Keyword.Type */
.highlight .m { color: #009999 } /* Literal.Number */
.highlight .s { color: #d14 } /* Literal.String */
.highlight .na { color: #008080 } /* Name.Attribute */
.highlight .nb { color: #0086B3 } /* Name.Builtin */
.highlight .nc { color: #445588; font-weight: bold } /* Name.Class */
.highlight .no { color: #008080 } /* Name.Constant */
.highlight .ni { color: #800080 } /* Name.Entity */
.highlight .ne { color: #990000; font-weight: bold } /* Name.Exception */
.highlight .nf { color: #990000; font-weight: bold } /* Name.Function */
.highlight .nn { color: #555555 } /* Name.Namespace */
.highlight .nt { color: #000080 } /* Name.Tag */
.highlight .nv { color: #008080 } /* Name.Variable */
.highlight .ow { font-weight: bold } /* Operator.Word */
.highlight .w { color: #bbbbbb } /* Text.Whitespace */
.highlight .mf { color: #009999 } /* Literal.Number.Float */
.highlight .mh { color: #009999 } /* Literal.Number.Hex */
.highlight .mi { color: #009999 } /* Literal.Number.Integer */
.highlight .mo { color: #009999 } /* Literal.Number.Oct */
.highlight .sb { color: #d14 } /* Literal.String.Backtick */
.highlight .sc { color: #d14 } /* Literal.String.Char */
.highlight .sd { color: #d14 } /* Literal.String.Doc */
.highlight .s2 { color: #d14 } /* Literal.String.Double */
.highlight .se { color: #d14 } /* Literal.String.Escape */
.highlight .sh { color: #d14 } /* Literal.String.Heredoc */
.highlight .si { color: #d14 } /* Literal.String.Interpol */
.highlight .sx { color: #d14 } /* Literal.String.Other */
.highlight .sr { color: #009926 } /* Literal.String.Regex */
.highlight .s1 { color: #d14 } /* Literal.String.Single */
.highlight .ss { color: #990073 } /* Literal.String.Symbol */
.highlight .bp { color: #999999 } /* Name.Builtin.Pseudo */
.highlight .vc { color: #008080 } /* Name.Variable.Class */
.highlight .vg { color: #008080 } /* Name.Variable.Global */
.highlight .vi { color: #008080 } /* Name.Variable.Instance */
.highlight .il { color: #009999 } /* Literal.Number.Integer.Long */
.type-csharp .highlight .k { color: #0000FF }
.type-csharp .highlight .kt { color: #0000FF }
.type-csharp .highlight .nf { color: #000000; font-weight: normal }
.type-csharp .highlight .nc { color: #2B91AF }
.type-csharp .highlight .nn { color: #000000 }
.type-csharp .highlight .s { color: #A31515 }
.type-csharp .highlight .sc { color: #A31515 }

479
stylesheets/stylesheet.css
View File

@ -1,479 +0,0 @@
/* http://meyerweb.com/eric/tools/css/reset/
v2.0 | 20110126
License: none (public domain)
*/
html, body, div, span, applet, object, iframe,
h1, h2, h3, h4, h5, h6, p, blockquote, pre,
a, abbr, acronym, address, big, cite, code,
del, dfn, em, img, ins, kbd, q, s, samp,
small, strike, strong, sub, sup, tt, var,
b, u, i, center,
dl, dt, dd, ol, ul, li,
fieldset, form, label, legend,
table, caption, tbody, tfoot, thead, tr, th, td,
article, aside, canvas, details, embed,
figure, figcaption, footer, header, hgroup,
menu, nav, output, ruby, section, summary,
time, mark, audio, video {
margin: 0;
padding: 0;
border: 0;
font-size: 100%;
font: inherit;
vertical-align: baseline;
}
/* HTML5 display-role reset for older browsers */
article, aside, details, figcaption, figure,
footer, header, hgroup, menu, nav, section {
display: block;
}
body {
line-height: 1;
}
ol, ul {
list-style: none;
}
blockquote, q {
quotes: none;
}
blockquote:before, blockquote:after,
q:before, q:after {
content: '';
content: none;
}
table {
border-collapse: collapse;
border-spacing: 0;
}
/* LAYOUT STYLES */
body {
font-size: 15px;
line-height: 1.5;
background: #fafafa url(../images/body-bg.jpg) 0 0 repeat;
font-family: 'Helvetica Neue', Helvetica, Arial, serif;
font-weight: 400;
color: #666;
}
a {
color: #2879d0;
}
a:hover {
color: #2268b2;
}
header {
padding-top: 40px;
padding-bottom: 40px;
font-family: 'Architects Daughter', 'Helvetica Neue', Helvetica, Arial, serif;
background: #2e7bcf url(../images/header-bg.jpg) 0 0 repeat-x;
border-bottom: solid 1px #275da1;
}
header h1 {
letter-spacing: -1px;
font-size: 72px;
color: #fff;
line-height: 1;
margin-bottom: 0.2em;
width: 540px;
}
header h2 {
font-size: 26px;
color: #9ddcff;
font-weight: normal;
line-height: 1.3;
width: 540px;
letter-spacing: 0;
}
.inner {
position: relative;
width: 940px;
margin: 0 auto;
}
#content-wrapper {
border-top: solid 1px #fff;
padding-top: 30px;
}
#main-content {
width: 690px;
float: left;
}
#main-content img {
max-width: 100%;
}
aside#sidebar {
width: 200px;
padding-left: 20px;
min-height: 504px;
float: right;
background: transparent url(../images/sidebar-bg.jpg) 0 0 no-repeat;
font-size: 12px;
line-height: 1.3;
}
aside#sidebar p.repo-owner,
aside#sidebar p.repo-owner a {
font-weight: bold;
}
#downloads {
margin-bottom: 40px;
}
a.button {
width: 134px;
height: 58px;
line-height: 1.2;
font-size: 23px;
color: #fff;
padding-left: 68px;
padding-top: 22px;
font-family: 'Architects Daughter', 'Helvetica Neue', Helvetica, Arial, serif;
}
a.button small {
display: block;
font-size: 11px;
}
header a.button {
position: absolute;
right: 0;
top: 0;
background: transparent url(../images/github-button.png) 0 0 no-repeat;
}
aside a.button {
width: 138px;
padding-left: 64px;
display: block;
background: transparent url(../images/download-button.png) 0 0 no-repeat;
margin-bottom: 20px;
font-size: 21px;
}
code, pre {
font-family: Monaco, "Bitstream Vera Sans Mono", "Lucida Console", Terminal, monospace;
color: #222;
margin-bottom: 30px;
font-size: 13px;
}
code {
background-color: #f2f8fc;
border: solid 1px #dbe7f3;
padding: 0 3px;
}
pre {
padding: 20px;
background: #fff;
text-shadow: none;
overflow: auto;
border: solid 1px #f2f2f2;
}
pre code {
color: #2879d0;
background-color: #fff;
border: none;
padding: 0;
}
ul, ol, dl {
margin-bottom: 20px;
}
/* COMMON STYLES */
hr {
height: 1px;
line-height: 1px;
margin-top: 1em;
padding-bottom: 1em;
border: none;
background: transparent url('../images/hr.png') 0 0 no-repeat;
}
table {
width: 100%;
border: 1px solid #ebebeb;
}
th {
font-weight: 500;
}
td {
border: 1px solid #ebebeb;
text-align: center;
font-weight: 300;
}
form {
background: #f2f2f2;
padding: 20px;
}
/* GENERAL ELEMENT TYPE STYLES */
#main-content h1 {
font-family: 'Architects Daughter', 'Helvetica Neue', Helvetica, Arial, serif;
font-size: 2.8em;
letter-spacing: -1px;
color: #474747;
}
#main-content h1:before {
content: "/";
color: #9ddcff;
padding-right: 0.3em;
margin-left: -0.9em;
}
#main-content h2 {
font-family: 'Architects Daughter', 'Helvetica Neue', Helvetica, Arial, serif;
font-size: 22px;
font-weight: bold;
margin-bottom: 8px;
color: #474747;
}
#main-content h2:before {
content: "//";
color: #9ddcff;
padding-right: 0.3em;
margin-left: -1.5em;
}
#main-content h3 {
font-family: 'Architects Daughter', 'Helvetica Neue', Helvetica, Arial, serif;
font-size: 18px;
font-weight: bold;
margin-top: 24px;
margin-bottom: 8px;
color: #474747;
}
#main-content h3:before {
content: "///";
color: #9ddcff;
padding-right: 0.3em;
margin-left: -2em;
}
#main-content h4 {
font-family: 'Architects Daughter', 'Helvetica Neue', Helvetica, Arial, serif;
font-size: 15px;
font-weight: bold;
color: #474747;
}
h4:before {
content: "////";
color: #9ddcff;
padding-right: 0.3em;
margin-left: -2.8em;
}
#main-content h5 {
font-family: 'Architects Daughter', 'Helvetica Neue', Helvetica, Arial, serif;
font-size: 14px;
color: #474747;
}
h5:before {
content: "/////";
color: #9ddcff;
padding-right: 0.3em;
margin-left: -3.2em;
}
#main-content h6 {
font-family: 'Architects Daughter', 'Helvetica Neue', Helvetica, Arial, serif;
font-size: .8em;
color: #474747;
}
h6:before {
content: "//////";
color: #9ddcff;
padding-right: 0.3em;
margin-left: -3.7em;
}
p {
margin-bottom: 20px;
}
a {
text-decoration: none;
}
p a {
font-weight: 400;
}
blockquote {
font-size: 1.6em;
border-left: 10px solid #e9e9e9;
margin-bottom: 20px;
padding: 0 0 0 30px;
}
ul {
list-style: disc inside;
padding-left: 20px;
}
ol {
list-style: decimal inside;
padding-left: 3px;
}
dl dd {
font-style: italic;
font-weight: 100;
}
footer {
background: transparent url('../images/hr.png') 0 0 no-repeat;
margin-top: 40px;
padding-top: 20px;
padding-bottom: 30px;
font-size: 13px;
color: #aaa;
}
footer a {
color: #666;
}
footer a:hover {
color: #444;
}
/* MISC */
.clearfix:after {
clear: both;
content: '.';
display: block;
visibility: hidden;
height: 0;
}
.clearfix {display: inline-block;}
* html .clearfix {height: 1%;}
.clearfix {display: block;}
/* #Media Queries
================================================== */
/* Smaller than standard 960 (devices and browsers) */
@media only screen and (max-width: 959px) {}
/* Tablet Portrait size to standard 960 (devices and browsers) */
@media only screen and (min-width: 768px) and (max-width: 959px) {
.inner {
width: 740px;
}
header h1, header h2 {
width: 340px;
}
header h1 {
font-size: 60px;
}
header h2 {
font-size: 30px;
}
#main-content {
width: 490px;
}
#main-content h1:before,
#main-content h2:before,
#main-content h3:before,
#main-content h4:before,
#main-content h5:before,
#main-content h6:before {
content: none;
padding-right: 0;
margin-left: 0;
}
}
/* All Mobile Sizes (devices and browser) */
@media only screen and (max-width: 767px) {
.inner {
width: 93%;
}
header {
padding: 20px 0;
}
header .inner {
position: relative;
}
header h1, header h2 {
width: 100%;
}
header h1 {
font-size: 48px;
}
header h2 {
font-size: 24px;
}
header a.button {
background-image: none;
width: auto;
height: auto;
display: inline-block;
margin-top: 15px;
padding: 5px 10px;
position: relative;
text-align: center;
font-size: 13px;
line-height: 1;
background-color: #9ddcff;
color: #2879d0;
-moz-border-radius: 5px;
-webkit-border-radius: 5px;
border-radius: 5px;
}
header a.button small {
font-size: 13px;
display: inline;
}
#main-content,
aside#sidebar {
float: none;
width: 100% ! important;
}
aside#sidebar {
background-image: none;
margin-top: 20px;
border-top: solid 1px #ddd;
padding: 20px 0;
min-height: 0;
}
aside#sidebar a.button {
display: none;
}
#main-content h1:before,
#main-content h2:before,
#main-content h3:before,
#main-content h4:before,
#main-content h5:before,
#main-content h6:before {
content: none;
padding-right: 0;
margin-left: 0;
}
}
/* Mobile Landscape Size to Tablet Portrait (devices and browsers) */
@media only screen and (min-width: 480px) and (max-width: 767px) {}
/* Mobile Portrait Size to Mobile Landscape Size (devices and browsers) */
@media only screen and (max-width: 479px) {}

23
tests/Map/MapTestSuite.hs Normal file
View File

@ -0,0 +1,23 @@
{-# LANGUAGE TemplateHaskell #-}
module Main where
import Test.QuickCheck
import Test.Framework
import Test.Framework.TH
import Test.Framework.Providers.QuickCheck2
import Map.Map
main :: IO ()
main = $(defaultMainGenerator)
prop_rd_idempot :: [Int] -> Bool
prop_rd_idempot xs = remdups xs == (remdups . remdups) xs
prop_rd_length :: [Int] -> Bool
prop_rd_length xs = length (remdups xs) <= length xs
prop_rd_sorted :: [Int] -> Property
prop_rd_sorted xs = (not . null) xs ==> head (remdups xs) == minimum xs