frag-1.1.1: src/ObjectBehavior.hs
{-# LANGUAGE BangPatterns #-}
module ObjectBehavior (aicube, camera) where
import Data.Maybe (fromJust)
import AFRP
import Camera
import IdentityList
import MD3
import Matrix
import Object
import Parser
ray ::
(Double, Double, Double) ->
(Double, Double, Double) -> ILKey -> ILKey -> Object
ray (!x, !y, !z) (!vx, !vy, !vz) firedfrom iD
= (arr
(\ oi ->
let clippedPos = oiCollisionPos oi in
let grounded = oiOnLand oi in ((), (clippedPos, grounded)))
>>>
(first (after 0.25 ()) >>>
arr
(\ (timeout, (clippedPos, grounded)) ->
(grounded, (clippedPos, timeout))))
>>>
(first ((iPre False) <<< identity) >>>
arr
(\ (cl, (clippedPos, timeout)) ->
let (vvx, vvy, vvz) = normalise $ vectorSub end start in
(clippedPos, (cl, timeout, vvx, vvy, vvz))))
>>>
(first ((iPre start) <<< (arr not0)) >>>
arr
(\ (clip, (cl, timeout, vvx, vvy, vvz)) ->
(vvx, (cl, clip, timeout, vvy, vvz))))
>>>
(first (arr (\ vvx -> 7500 * vvx) >>> integral) >>>
arr
(\ (ucx, (cl, clip, timeout, vvy, vvz)) ->
(vvy, (cl, clip, timeout, ucx, vvz))))
>>>
(first (arr (\ vvy -> 7500 * vvy) >>> integral) >>>
arr
(\ (ucy, (cl, clip, timeout, ucx, vvz)) ->
(vvz, (cl, clip, timeout, ucx, ucy))))
>>>
(first (arr (\ vvz -> 7500 * vvz) >>> integral) >>>
arr
(\ (ucz, (cl, clip, timeout, ucx, ucy)) ->
(cl, (cl, clip, timeout, ucx, ucy, ucz))))
>>>
(first edge >>>
arr
(\ (clipev, (cl, clip, timeout, ucx, ucy, ucz)) ->
ObjOutput{ooObsObjState =
OOSRay{rayStart = start, rayEnd = clip,
rayUC = vectorAdd start (ucx, ucy, ucz), clipped = cl,
firedFrom = firedfrom},
ooKillReq = timeout, ooSpawnReq = noEvent,
ooSendMessage =
clipev `tag` [(firedfrom, (iD, Coord clip))]})))
where (start, end) = firePos (x, y, z) (vx, vy, vz)
(_, _, _) = normalise $ vectorSub end start
not0 c
| c /= (0, 0, 0) = c
| otherwise = (x, y, z)
projectile :: (Vec3, Vec3) -> ILKey -> ILKey -> Object
projectile ((sx, sy, sz), (vx, vy, vz)) firedfrom _
= (arr
(\ oi ->
let grounded = oiOnLand oi in
let hits = oiHit oi in (hits, grounded))
>>>
(first identity >>> arr (\ (hit, grounded) -> (grounded, hit))) >>>
((first ((iPre False) <<< identity) >>> first edge) >>>
arr (\ (clipEv, hit) -> ((), (clipEv, hit))))
>>>
(first (arr (\ () -> 1500 * vx) >>> imIntegral sx) >>>
arr (\ (x, (clipEv, hit)) -> ((), (clipEv, hit, x))))
>>>
(first (arr (\ () -> 1500 * vy) >>> imIntegral sy) >>>
arr (\ (y, (clipEv, hit, x)) -> ((), (clipEv, hit, x, y))))
>>>
(first (arr (\ () -> 1500 * vz) >>> imIntegral sz) >>>
arr
(\ (z, (clipEv, hit, x, y)) ->
((x, y, z), (clipEv, hit, x, y, z))))
>>>
(first (iPre (sx, sy, sz) <<< identity) >>>
arr
(\ (oldpos, (clipEv, hit, x, y, z)) ->
((clipEv, hit), (oldpos, x, y, z))))
>>>
(first
(arr (\ (clipEv, hit) -> (isEvent clipEv || isEvent hit)) >>> edge)
>>>
arr
(\ (hitEv, (oldpos, x, y, z)) ->
ObjOutput{ooObsObjState =
OOSProjectile{projectileOldPos = oldpos,
projectileNewPos = (x, y, z),
firedFrom = firedfrom},
ooKillReq = hitEv, ooSpawnReq = noEvent,
ooSendMessage = noEvent})))
camera ::
Camera ->
[(String, AnimState, AnimState)] ->
[(ILKey, Message)] -> ILKey -> Object
camera cam _ _ iD
= (arr
(\ oi ->
let gi = oiGameInput oi in
let clippedcam = oiCollision oi in
let grounded = oiOnLand oi in
let msgs = oiMessage oi in
(gi, (clippedcam, gi, grounded, msgs, oi)))
>>>
(first ptrPos >>>
arr
(\ (pPos, (clippedcam, gi, grounded, msgs, oi)) ->
(gi, (clippedcam, gi, grounded, msgs, oi, pPos))))
>>>
(first (movementKS 400) >>>
arr
(\ (forwardVel, (clippedcam, gi, grounded, msgs, oi, pPos)) ->
(gi, (clippedcam, forwardVel, gi, grounded, msgs, oi, pPos))))
>>>
(first (strafeKS 400) >>>
arr
(\ (strafeVel,
(clippedcam, forwardVel, gi, grounded, msgs, oi, pPos))
->
(gi,
(clippedcam, forwardVel, gi, grounded, msgs, oi, pPos,
strafeVel))))
>>>
(first lbp >>>
arr
(\ (trigger,
(clippedcam, forwardVel, gi, grounded, msgs, oi, pPos, strafeVel))
->
(gi,
(clippedcam, forwardVel, gi, grounded, msgs, oi, pPos, strafeVel,
trigger))))
>>>
(first rbp >>>
arr
(\ (rtrigger,
(clippedcam, forwardVel, gi, grounded, msgs, oi, pPos, strafeVel,
trigger))
->
(gi,
(clippedcam, forwardVel, gi, grounded, msgs, oi, pPos, rtrigger,
strafeVel, trigger))))
>>>
(first getDt >>>
arr
(\ (dt,
(clippedcam, forwardVel, gi, grounded, msgs, oi, pPos, rtrigger,
strafeVel, trigger))
->
((clippedcam, pPos),
(clippedcam, dt, forwardVel, gi, grounded, msgs, oi, rtrigger,
strafeVel, trigger))))
>>>
(first
(arr (\ (clippedcam, pPos) -> (pPos, clippedcam)) >>>
((iPre cam) <<< (arr setView)))
>>>
arr
(\ (cam1,
(clippedcam, dt, forwardVel, gi, grounded, msgs, oi, rtrigger,
strafeVel, trigger))
->
((cam1, dt, forwardVel),
(cam1, clippedcam, dt, gi, grounded, msgs, oi, rtrigger, strafeVel,
trigger))))
>>>
(first
(arr (\ (cam1, dt, forwardVel) -> (forwardVel * dt, cam1)) >>>
moves)
>>>
arr
(\ (cam2,
(cam1, clippedcam, dt, gi, grounded, msgs, oi, rtrigger, strafeVel,
trigger))
->
((cam2, dt, strafeVel),
(cam1, clippedcam, gi, grounded, msgs, oi, rtrigger, trigger))))
>>>
(first
(arr (\ (cam2, dt, strafeVel) -> (strafeVel * dt, cam2)) >>>
strafes)
>>>
arr
(\ (cam3,
(cam1, clippedcam, gi, grounded, msgs, oi, rtrigger, trigger))
->
((gi, grounded),
(cam1, cam3, clippedcam, msgs, oi, rtrigger, trigger))))
>>>
(first (arr (\ (gi, grounded) -> (grounded, gi)) >>> fallingp) >>>
arr
(\ (yVel, (cam1, cam3, clippedcam, msgs, oi, rtrigger, trigger)) ->
((cam3, yVel), (cam1, clippedcam, msgs, oi, rtrigger, trigger))))
>>>
((first (arr dropCam) >>>
loop
(arr
(\ ((cam4, (cam1, clippedcam, msgs, oi, rtrigger, trigger)),
msgn)
->
((msgn, msgs, rtrigger),
(cam1, cam4, clippedcam, msgs, oi, rtrigger, trigger)))
>>>
(first
(arr
(\ (msgn, msgs, rtrigger) ->
case (isEvent rtrigger) of
True -> ([], msgn)
False -> ((getMsg0 msgs msgn), msgn))
>>> ((iPre ([], [])) <<< identity))
>>>
arr
(\ ((msgn, msgi),
(cam1, cam4, clippedcam, msgs, oi, rtrigger, trigger))
->
((cam1, cam4, clippedcam, msgi, msgs, oi, rtrigger,
trigger),
msgn)))))
>>>
arr
(\ (cam1, cam4, clippedcam, msgi, msgs, oi, rtrigger, trigger) ->
(oi, (cam1, cam4, clippedcam, msgi, msgs, rtrigger, trigger))))
>>>
((first (arr (\ oi -> oiHit oi) >>> (iPre (noEvent) <<< identity))
>>>
loop
(arr
(\ ((hitEv,
(cam1, cam4, clippedcam, msgi, msgs, rtrigger, trigger)),
currentHealth)
->
((currentHealth, hitEv),
(cam1, cam4, clippedcam, msgi, msgs, rtrigger, trigger)))
>>>
(first
(arr
(\ (currentHealth, hitEv) ->
case (isEvent hitEv) of
True -> currentHealth -
(realToFrac
((length (fromEvent hitEv)) * 3))
False -> currentHealth)
>>> ((iPre 100) <<< identity))
>>>
arr
(\ (currentHealth,
(cam1, cam4, clippedcam, msgi, msgs, rtrigger,
trigger))
->
((cam1, cam4, clippedcam, currentHealth, msgi, msgs,
rtrigger, trigger),
currentHealth)))))
>>>
arr
(\ (cam1, cam4, clippedcam, currentHealth, msgi, msgs, rtrigger,
trigger)
->
(msgs,
(cam1, cam4, clippedcam, currentHealth, msgi, rtrigger,
trigger))))
>>>
((first ((iPre noEvent) <<< identity) >>>
loop
(arr
(\ ((msges,
(cam1, cam4, clippedcam, currentHealth, msgi, rtrigger,
trigger)),
kills)
->
((kills, msges),
(cam1, cam4, clippedcam, currentHealth, msges, msgi,
rtrigger, trigger)))
>>>
(first
(arr
(\ (kills, msges) ->
kills + (length (findKills (event2List msges))))
>>> ((iPre 0) <<< identity))
>>>
arr
(\ (kills,
(cam1, cam4, clippedcam, currentHealth, msges,
msgi, rtrigger, trigger))
->
((cam1, cam4, clippedcam, currentHealth, kills,
msges, msgi, rtrigger, trigger),
kills)))))
>>>
arr
(\ (cam1, cam4, clippedcam, currentHealth, kills, msges, msgi,
rtrigger, trigger)
->
((msgi, rtrigger),
(cam1, cam4, clippedcam, currentHealth, kills, msges,
trigger))))
>>>
(first
(arr (\ (msgi, rtrigger) -> (rtrigger, msgi)) >>>
((iPre (noEvent, [])) <<< identity))
>>>
arr
(\ ((rev, msgi2),
(cam1, cam4, clippedcam, currentHealth, kills, msges,
trigger))
->
(clippedcam,
(cam1, cam4, currentHealth, kills, msges, msgi2, rev,
trigger))))
>>>
(first ((iPre cam) <<< identity) >>>
arr
(\ (ccam,
(cam1, cam4, currentHealth, kills, msges, msgi2, rev,
trigger))
->
ObjOutput{ooSpawnReq =
(trigger `tag`
[(ray (cpos cam1) (viewPos cam1) iD)]),
ooObsObjState =
OOSCamera{newCam = cam4, oldCam = cam1,
health = currentHealth, ammo = 100,
score = kills,
cood =
case (isEvent rev) of
True -> reverse $
map getCoordFromMsg
(msgi2)
_ -> []},
ooKillReq = noEvent,
ooSendMessage =
case (event2List msges) of
[] -> noEvent
_ -> (Event ()) `tag`
(case
(findEnemies
(event2List msges))
of
[] -> []
_ -> [toTargetPosition iD
(cpos ccam)
(head
(findEnemies
(event2List
msges)))])})))
event2List :: Event [a] -> [a]
event2List ev
| isEvent ev = fromEvent ev
| otherwise = []
getMsg0 ::
Event [(ILKey, Message)] ->
[(ILKey, Message)] -> [(ILKey, Message)]
getMsg0 (ev) ls
= case (isEvent ev) of
True -> case ((findCoords (fromEvent ev)) ++ ls) of
x -> x
_ -> ls
findKills :: [(ILKey, Message)] -> [ILKey]
findKills ((k, EnemyDown) : kmsgs) = k : (findKills kmsgs)
findKills ((_, _) : kmsgs) = (findKills kmsgs)
findKills [] = []
findEnemies :: [(ILKey, Message)] -> [ILKey]
findEnemies ((k, PlayerLockedOn) : kmsgs) = k : (findEnemies kmsgs)
findEnemies ((_, _) : kmsgs) = (findEnemies kmsgs)
findEnemies [] = []
toTargetPosition ::
ILKey -> Vec3 -> ILKey -> (ILKey, (ILKey, Message))
toTargetPosition iD position contact
= (contact, (iD, TargetPosition position))
findCoords :: [(ILKey, Message)] -> [(ILKey, Message)]
findCoords ((k, Coord x) : kmsgs)
= (k, Coord x) : (findCoords kmsgs)
findCoords ((_, _) : kmsgs) = findCoords kmsgs
findCoords [] = []
getCoordFromMsg :: (ILKey, Message) -> Vec3
getCoordFromMsg (_, (Coord xyz)) = xyz
getCoordFromMsg _ = (0,0,0)
aicube ::
(Double, Double, Double) ->
(Double, Double, Double) ->
[(Double, Double, Double)] ->
String -> (AnimState, AnimState) -> ILKey -> Object
aicube (x, y, z) size waypoints modelname (ua, la) iD
= (((arr (\ oi -> let gi = oiGameInput oi in (gi, oi)) >>>
first getT)
>>>
arr
(\ (t, oi) ->
let hitList = oiHit oi in
let enemySighted = oiVisibleObjs oi in
(hitList, (enemySighted, hitList, oi, t))))
>>>
(first
(arr
(\ hitList ->
case (isEvent hitList) of
True -> getFire (snd (head (fromEvent hitList)))
_ -> Nothing)
>>> (iPre Nothing <<< identity))
>>>
arr
(\ (hitSource, (enemySighted, hitList, oi, t)) ->
(hitSource, (enemySighted, hitList, hitSource, oi, t))))
>>>
((first (arr (\ hitSource -> (hitSource /= Nothing)) >>> edge) >>>
loop
(arr
(\ ((hitev1, (enemySighted, hitList, hitSource, oi, t)),
currentHealth)
->
((currentHealth, hitList),
(enemySighted, hitSource, hitev1, oi, t)))
>>>
(first
(arr
(\ (currentHealth, hitList) ->
case (isEvent hitList) of
True -> currentHealth - (3)
False -> currentHealth)
>>> ((iPre 100) <<< identity))
>>>
arr
(\ (currentHealth, (enemySighted, hitSource, hitev1, oi, t)) ->
((currentHealth, enemySighted, hitSource, hitev1, oi, t),
currentHealth)))))
>>>
arr
(\ (currentHealth, enemySighted, hitSource, hitev1, oi, t) ->
(currentHealth,
(currentHealth, enemySighted, hitSource, hitev1, oi, t))))
>>>
((first (arr (\ currentHealth -> (currentHealth <= 0)) >>> edge)
>>>
loop
(arr
(\ ((hitev,
(currentHealth, enemySighted, hitSource, hitev1, oi, t)),
isDead)
->
((hitev, isDead),
(currentHealth, enemySighted, hitSource, hitev, hitev1, oi, t)))
>>>
(first
(arr
(\ (hitev, isDead) ->
case (isEvent hitev) of
True -> True
_ -> isDead)
>>> ((iPre False) <<< identity))
>>>
arr
(\ (isDead,
(currentHealth, enemySighted, hitSource, hitev, hitev1, oi, t))
->
((currentHealth, enemySighted, hitSource, hitev, hitev1, isDead,
oi, t),
isDead)))))
>>>
arr
(\ (currentHealth, enemySighted, hitSource, hitev, hitev1, isDead,
oi, t)
->
((enemySighted, isDead),
(currentHealth, enemySighted, hitSource, hitev, hitev1, isDead, oi,
t))))
>>>
(((first
(arr
(\ (enemySighted, isDead) ->
(isEvent enemySighted) && (isDead == False))
>>> ((iPre noEvent) <<< edge))
>>>
loop
(arr
(\ ((enemyS,
(currentHealth, enemySighted, hitSource, hitev, hitev1, isDead, oi,
t)),
enemy)
->
((enemy, enemySighted),
(currentHealth, enemyS, enemySighted, hitSource, hitev, hitev1,
isDead, oi, t)))
>>>
(first
(arr
(\ (enemy, enemySighted) ->
case (isEvent enemySighted) of
True -> enemySighted
False -> enemy)
>>> ((iPre noEvent) <<< identity))
>>>
arr
(\ (enemy,
(currentHealth, enemyS, enemySighted, hitSource, hitev, hitev1,
isDead, oi, t))
->
((currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,
hitev1, isDead, oi, t),
enemy)))))
>>>
loop
(arr
(\ ((currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,
hitev1, isDead, oi, t),
targ)
->
((enemySighted, targ),
(currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,
hitev1, isDead, oi, t)))
>>>
(first
(arr
(\ (enemySighted, targ) ->
case (isEvent enemySighted) of
True -> (cpos (oldCam (snd (head (fromEvent enemySighted)))))
False -> targ)
>>> ((iPre (0, 0, 0)) <<< identity))
>>>
arr
(\ (targ,
(currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,
hitev1, isDead, oi, t))
->
((currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,
hitev1, isDead, oi, t, targ),
targ)))))
>>>
arr
(\ (currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,
hitev1, isDead, oi, t, targ)
->
(oi,
(currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,
hitev1, isDead, oi, t, targ))))
>>>
(first
(arr (\ oi -> oiMessage oi) >>> ((iPre noEvent) <<< identity))
>>>
arr
(\ (msgs,
(currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,
hitev1, isDead, oi, t, targ))
->
((isDead, msgs),
(currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,
hitev1, isDead, msgs, oi, t, targ))))
>>>
(first
(arr
(\ (isDead, msgs) ->
case (isEvent msgs) && (isDead == False) of
True -> case (getTargetPosition (fromEvent msgs)) of
Just _ -> True
_ -> False
_ -> False)
>>> edge)
>>>
arr
(\ (msgReceived,
(currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,
hitev1, isDead, msgs, oi, t, targ))
->
((isDead, msgs),
(currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,
hitev1, isDead, msgReceived, oi, t, targ))))
>>>
(first
(arr
(\ (isDead, msgs) ->
case (isEvent msgs) && (isDead == False) of
True -> case (getTargetPosition2 (fromEvent msgs)) of
Just _ -> True
_ -> False
_ -> False)
>>> edge)
>>>
arr
(\ (respond2Attack,
(currentHealth, enemy, enemyS, enemySighted, hitSource, hitev,
hitev1, isDead, msgReceived, oi, t, targ))
->
((enemySighted, msgReceived),
(currentHealth, enemy, enemyS, hitSource, hitev, hitev1, isDead,
oi, respond2Attack, t, targ))))
>>>
(first
(arr
(\ (enemySighted, msgReceived) ->
(isNoEvent enemySighted) && (isNoEvent msgReceived))
>>> ((iPre noEvent) <<< edge))
>>>
arr
(\ (targetLost1,
(currentHealth, enemy, enemyS, hitSource, hitev, hitev1, isDead,
oi, respond2Attack, t, targ))
->
((enemyS, targetLost1),
(currentHealth, enemy, enemyS, hitSource, hitev, hitev1, isDead,
oi, respond2Attack, t, targ, targetLost1))))
>>>
(first
(arr
(\ (enemyS, targetLost1) ->
((),
(enemyS `tag` (constant noEvent)) `lMerge`
(targetLost1 `tag` (repeatedly (0.5) (Event ())))))
>>> rSwitch (constant noEvent))
>>>
loop
(arr
(\ ((_,
(currentHealth, enemy, enemyS, hitSource, hitev, hitev1, isDead,
oi, respond2Attack, t, targ, targetLost1)),
~(angle, lEndEv, oldPos, uEndEv))
->
((angle, enemyS, hitev, lEndEv, oi, oldPos, respond2Attack,
uEndEv),
(currentHealth, enemy, hitSource, hitev, hitev1, isDead, t, targ,
targetLost1)))
>>>
(first
(arr
(\ (angle, enemyS, hitev, lEndEv, oi, oldPos, respond2Attack,
uEndEv)
->
((oi, uEndEv, lEndEv),
(enemyS `tag` (turnToFaceTarget (oldPos, angle))) `lMerge`
respond2Attack
`tag` (turnToFaceTarget (oldPos, angle))
`lMerge` hitev
`tag` playDead oldPos angle))
>>> drSwitch (followWayPoints (x, y, z) waypoints))
>>>
arr
(\ ((newPos, oldPos, angle, ptch, attack,
(upperIdx, lowerIdx)),
(currentHealth, enemy, hitSource, hitev, hitev1, isDead, t,
targ, targetLost1))
->
((t, upperIdx),
(angle, attack, currentHealth, enemy, hitSource, hitev,
hitev1, isDead, lowerIdx, newPos, oldPos, ptch, t, targ,
targetLost1))))
>>>
(first (updateAnimSF ua) >>>
arr
(\ ((uEndEv, upperstate),
(angle, attack, currentHealth, enemy, hitSource, hitev,
hitev1, isDead, lowerIdx, newPos, oldPos, ptch, t, targ,
targetLost1))
->
((lowerIdx, t),
(angle, attack, currentHealth, enemy, hitSource, hitev,
hitev1, isDead, newPos, oldPos, ptch, targ, targetLost1,
uEndEv, upperstate))))
>>>
(first
(arr (\ (lowerIdx, t) -> (t, lowerIdx)) >>> updateAnimSF la)
>>>
arr
(\ ((lEndEv, lowerstate),
(angle, attack, currentHealth, enemy, hitSource, hitev,
hitev1, isDead, newPos, oldPos, ptch, targ,
targetLost1, uEndEv, upperstate))
->
((angle, attack, currentHealth, enemy, hitSource, hitev,
hitev1, isDead, lowerstate, newPos, oldPos, ptch,
targ, targetLost1, upperstate),
(angle, lEndEv, oldPos, uEndEv))))))
>>>
arr
(\ (angle, attack, currentHealth, enemy, hitSource, hitev, hitev1,
isDead, lowerstate, newPos, oldPos, ptch, targ, targetLost1,
upperstate)
->
let f = 1 in
ObjOutput{ooObsObjState =
OOSAICube{oosNewCubePos = newPos,
oosOldCubePos = oldPos, oosCubeSize = size,
oosCubeAngle = angle, oosCubePitch = ptch,
upperAnim = upperstate,
lowerAnim = lowerstate,
health = currentHealth, target = targ,
fade = f, modelName = modelname},
ooKillReq = noEvent,
ooSpawnReq =
attack `tag`
[projectile (getMuzzlePoint (oldPos, targ)) iD],
ooSendMessage =
hitev `tag`
(case isDead of
False -> [(fromJust hitSource, (iD, EnemyDown))]
_ -> [])
`lMerge` targetLost1
`tag`
[(fst (head (fromEvent enemy)), (iD, PlayerLockedOn))]
`lMerge` hitev1
`tag` [(fromJust hitSource, (iD, PlayerLockedOn2))]}))
getFire :: ObsObjState -> Maybe ILKey
getFire obj
| isRay obj = Just (firedFrom obj)
| otherwise = Nothing
getTargetPosition :: [(ILKey, Message)] -> Maybe Vec3
getTargetPosition ((_, TargetPosition pos) : _) = Just pos
getTargetPosition (_ : rest) = getTargetPosition rest
getTargetPosition [] = Nothing
getTargetPosition2 :: [(ILKey, Message)] -> Maybe Vec3
getTargetPosition2 ((_, TargetPosition2 pos) : _) = Just pos
getTargetPosition2 (_ : rest) = getTargetPosition2 rest
getTargetPosition2 [] = Nothing
getMuzzlePoint :: (Vec3, Vec3) -> (Vec3, Vec3)
getMuzzlePoint ((x, y, z), (ox, oy, oz))
= let (x3, _, z3)
= normalise $ (vectorSub (ox, oy + 45, oz) (x, y, z))
(x7, _, z7) = normalise $ (vectorSub (ox, 0, oz) (x, 0, z))
(x4, _, z4) = normalise $ crossProd (x3, 0, z3) (0, 1, 0)
(x5, y5, z5)
= (x + (x7 * (- 18.55)) + (x4 * (9.6)), y + 4,
z + (z7 * (- 18.55)) + (z4 * (9.6)))
(x12, y12, z12)
= normalise $ (vectorSub (ox, oy - 5, oz) (x, y, z))
(x6, y6, z6)
= vectorAdd (x5, y5, z5) (x12 * 42, y12 * 42, z12 * 42)
(x9, y9, z9) = normalise $ (vectorSub (x6, y6, z6) (x5, y5, z5))
(x10, y10, z10) = normalise $ crossProd (x9, y9, z9) (0, 1, 0)
(x13, y13, z13)
= normalise $ crossProd (x9, y9, z9) (x10, y10, z10)
muzzlePoint
= vectorAdd (x6, y6, z6)
(x13 * (- 9.5), y13 * (- 9.5), z13 * (- 9.5))
muzzleEnd
= vectorAdd (x5, y5, z5)
(x13 * (- 9.5), y13 * (- 9.5), z13 * (- 9.5))
fireVec = normalise $ (vectorSub muzzlePoint muzzleEnd)
in (muzzlePoint, fireVec)
falling :: SF (Bool, GameInput, Double) Double
falling
= (loop
(arr
(\ ((lnd, _, dt), pos) ->
case lnd of
True -> (- 0.5)
False -> (pos - (6 * 200 * dt)))
>>> (((iPre 0) <<< identity) >>> arr (\ pos -> (pos, pos)))))
turnToFaceTarget ::
(Vec3, Double) ->
SF (ObjInput, Event (), Event ())
(Vec3, Vec3, Double, Double, Event (), (Int, Int))
turnToFaceTarget (currentPos, initialAngle)
= (arr
(\ (oi, ev1, ev2) ->
let gi = oiGameInput oi in
let clippedPos = oiCollisionPos oi in
let grounded = oiOnLand oi in
(gi, (clippedPos, ev1, ev2, gi, grounded, oi)))
>>>
((first getDt >>>
loop
(arr
(\ ((dt, (clippedPos, ev1, ev2, gi, grounded, oi)), count) ->
(count, (clippedPos, dt, ev1, ev2, gi, grounded, oi)))
>>>
(first (arr (\ count -> count + 1) >>> ((iPre 0) <<< identity)) >>>
arr
(\ (count, (clippedPos, dt, ev1, ev2, gi, grounded, oi)) ->
((clippedPos, count, dt, ev1, ev2, gi, grounded, oi), count)))))
>>>
arr
(\ (clippedPos, count, dt, ev1, ev2, gi, grounded, oi) ->
(clippedPos, (count, dt, ev1, ev2, gi, grounded, oi))))
>>>
(first ((iPre currentPos) <<< identity) >>>
arr
(\ ((ox1, oy1, oz1), (count, dt, ev1, ev2, gi, grounded, oi)) ->
((count, ox1, oy1, oz1), (dt, ev1, ev2, gi, grounded, oi))))
>>>
(first
(arr
(\ (count, ox1, oy1, oz1) ->
case (count > (3 :: Int) && (ox1, oy1, oz1) /= currentPos) of
True -> (ox1, oy1, oz1)
_ -> currentPos)
>>> identity)
>>>
arr
(\ ((ox, oy, oz), (dt, ev1, ev2, gi, grounded, oi)) ->
((dt, gi, grounded), (ev1, ev2, oi, ox, oy, oz))))
>>>
((((((first
(arr (\ (dt, gi, grounded) -> (grounded, gi, dt)) >>>
((iPre 0) <<< falling))
>>>
arr
(\ (yVel, (ev1, ev2, oi, ox, oy, oz)) ->
let enemySighted = oiVisibleObjs oi in
(enemySighted, ev1, ev2, ox, oy, oz, yVel)))
>>>
loop
(arr
(\ ((enemySighted, ev1, ev2, ox, oy, oz, yVel), targetAnglei) ->
((enemySighted, ox, oy, oz, targetAnglei),
(enemySighted, ev1, ev2, ox, oy, oz, yVel)))
>>>
(first
(arr
(\ (enemySighted, ox, oy, oz, targetAnglei) ->
case (isEvent enemySighted) of
True -> getAngle
((ox, oy, oz),
(cpos
(oldCam (snd (head (fromEvent enemySighted))))))
_ -> targetAnglei)
>>> ((iPre initialAngle) <<< identity))
>>>
arr
(\ (targetAnglei, (enemySighted, ev1, ev2, ox, oy, oz, yVel)) ->
((enemySighted, ev1, ev2, ox, oy, oz, targetAnglei, yVel),
targetAnglei)))))
>>>
loop
(arr
(\ ((enemySighted, ev1, ev2, ox, oy, oz, targetAnglei, yVel),
angle)
->
let targetAngle
= case
(abs (angle - targetAnglei) <
abs (angle - (targetAnglei + 360)))
of
True -> targetAnglei
False -> targetAnglei + 360
in
let angularV
= case (True) of
True -> case (abs (angle - targetAngle) > 2) of
True -> case (angle < targetAngle) of
True -> 270
_ -> - 270
False -> (targetAngle - angle)
False -> 0
in
(angularV,
(enemySighted, ev1, ev2, ox, oy, oz, targetAngle, yVel)))
>>>
(first ((initialAngle +) ^<< integral) >>>
arr
(\ (angle, (enemySighted, ev1, ev2, ox, oy, oz, targetAngle, yVel))
->
let legState
= case (abs (angle - targetAngle) < 2) of
True -> idleLegs
_ -> turn
in
((ev2, legState),
(angle, enemySighted, ev1, legState, ox, oy, oz, targetAngle,
yVel))))
>>>
(first
(arr
(\ (ev2, legState) -> ((legState == idleLegs) && (isEvent ev2)))
>>> edge)
>>>
arr
(\ (switch2idle,
(angle, enemySighted, ev1, legState, ox, oy, oz, targetAngle,
yVel))
->
(legState,
(angle, enemySighted, ev1, ox, oy, oz, switch2idle, targetAngle,
yVel))))
>>>
(first (arr (\ legState -> (legState == turn)) >>> edge) >>>
arr
(\ (turning,
(angle, enemySighted, ev1, ox, oy, oz, switch2idle,
targetAngle, yVel))
->
((switch2idle, turning),
(angle, enemySighted, ev1, ox, oy, oz, targetAngle, yVel))))
>>>
(first
(arr
(\ (switch2idle, turning) ->
((),
turning `tag` (constant turn) `lMerge` switch2idle `tag`
(constant idleLegs)))
>>> drSwitch (constant stand))
>>>
arr
(\ (legsAnim,
(angle, enemySighted, ev1, ox, oy, oz, targetAngle, yVel))
->
((angle, enemySighted, ev1, legsAnim, ox, oy, oz, targetAngle,
yVel),
angle)))))
>>>
loop
(arr
(\ ((angle, enemySighted, ev1, legsAnim, ox, oy, oz, targetAngle,
yVel),
targetPitch)
->
((enemySighted, ox, oy, oz, targetPitch),
(angle, enemySighted, ev1, legsAnim, ox, oy, oz, targetAngle,
yVel)))
>>>
(first
(arr
(\ (enemySighted, ox, oy, oz, targetPitch) ->
case (isEvent enemySighted) of
True -> getVertAngle
((ox, oy, oz),
vectorAdd
(cpos
(oldCam (snd (head (fromEvent enemySighted)))))
(0, - 5, 0))
_ -> targetPitch)
>>> ((iPre 0) <<< identity))
>>>
arr
(\ (targetPitch,
(angle, enemySighted, ev1, legsAnim, ox, oy, oz, targetAngle,
yVel))
->
((angle, enemySighted, ev1, legsAnim, ox, oy, oz, targetAngle,
targetPitch, yVel),
targetPitch)))))
>>>
loop
(arr
(\ ((angle, enemySighted, ev1, legsAnim, ox, oy, oz, targetAngle,
targetPitch, yVel),
ptch)
->
let angularVP
= case (abs (ptch - targetPitch) > 2) of
True -> case (targetPitch < ptch) of
True -> - 90
_ -> 90
False -> (targetPitch - ptch)
in
(angularVP,
(angle, enemySighted, ev1, legsAnim, ox, oy, oz, targetAngle,
targetPitch, yVel)))
>>>
(first ((0 +) ^<< integral) >>>
arr
(\ (ptch,
(angle, enemySighted, ev1, legsAnim, ox, oy, oz, targetAngle,
targetPitch, yVel))
->
((angle, enemySighted, ev1, legsAnim, ox, oy, oz, ptch,
targetAngle, targetPitch, yVel),
ptch)))))
>>>
arr
(\ (angle, enemySighted, ev1, legsAnim, ox, oy, oz, ptch,
targetAngle, targetPitch, yVel)
->
(ev1,
(angle, enemySighted, legsAnim, ox, oy, oz, ptch, targetAngle,
targetPitch, yVel))))
>>>
(first (arr (\ ev1 -> (isEvent ev1)) >>> ((iPre noEvent) <<< edge))
>>>
arr
(\ (attack,
(angle, enemySighted, legsAnim, ox, oy, oz, ptch, targetAngle,
targetPitch, yVel))
->
((angle, enemySighted, ptch, targetAngle, targetPitch),
(angle, attack, legsAnim, ox, oy, oz, ptch, yVel))))
>>>
(first
(arr
(\ (angle, enemySighted, ptch, targetAngle, targetPitch) ->
case
((abs (ptch - targetPitch) < 6) && (abs (angle - targetAngle) < 6)
&& isEvent enemySighted)
of
True -> attack1
False -> stand)
>>> ((iPre stand) <<< identity))
>>>
arr
(\ (torsoAnim, (angle, attack, legsAnim, ox, oy, oz, ptch, yVel))
->
((ox, oy + yVel, oz), (ox, oy, oz), angle, ptch, attack,
(torsoAnim, legsAnim)))))
followWayPoints ::
Vec3 ->
[Vec3] ->
SF (ObjInput, Event (), Event ())
(Vec3, Vec3, Double, Double, Event (), (Int, Int))
followWayPoints (x, y, z) waypoints
= (arr
(\ (oi, ev1, ev2) ->
let gi = oiGameInput oi in
let clippedPos = oiCollisionPos oi in
let grounded = oiOnLand oi in
(clippedPos, (ev1, ev2, gi, grounded, oi)))
>>>
(first ((iPre (x, y, z)) <<< identity) >>>
arr
(\ ((ox, oy, oz), (ev1, ev2, gi, grounded, oi)) ->
(gi, (ev1, ev2, gi, grounded, oi, ox, oy, oz))))
>>>
(first getT >>>
arr
(\ (_, (ev1, ev2, gi, grounded, oi, ox, oy, oz)) ->
(gi, (ev1, ev2, gi, grounded, oi, ox, oy, oz))))
>>>
(first getDt >>>
arr
(\ (dt, (ev1, ev2, gi, grounded, oi, ox, oy, oz)) ->
((dt, gi, grounded), (dt, ev1, ev2, oi, ox, oy, oz))))
>>>
(first
(arr (\ (dt, gi, grounded) -> (grounded, gi, dt)) >>>
((iPre 0) <<< falling))
>>>
loop
(arr
(\ ((yVel, (dt, ev1, ev2, oi, ox, oy, oz)), wpl) ->
(wpl, (dt, ev1, ev2, oi, ox, oy, oz, yVel)))
>>>
(first ((iPre (cycle waypoints)) <<< identity) >>>
arr
(\ (wps, (dt, ev1, ev2, oi, ox, oy, oz, yVel)) ->
let [wp1, wp2] = take 2 wps in
let (pastWp, (dx, _, dz)) = stepdist wp1 wp2 (ox, oy, oz) 100 dt
in
(pastWp,
(dx, dz, ev1, ev2, oi, ox, oy, oz, pastWp, wp2, wps, yVel))))
>>>
(first edge >>>
arr
(\ (pastEv,
(dx, dz, ev1, ev2, oi, ox, oy, oz, pastWp, wp2, wps, yVel))
->
let angle = getAngle ((ox, oy, oz), (ox + dx, oy + yVel, oz + dz))
in
let newPos = (ox + dx, oy + yVel, oz + dz) in
((angle, ev1, ev2, newPos, oi, pastEv, wp2),
(angle, newPos, ox, oy, oz, pastWp, wps))))
>>>
(first
(arr
(\ (angle, ev1, ev2, newPos, oi, pastEv, wp2) ->
((oi, ev1, ev2),
pastEv `tag` (turnToNextWp angle (getAngle (newPos, wp2)))))
>>>
rSwitch
(constant (True, False, (getAngle ((x, y, z), head waypoints)))))
>>>
arr
(\ ((notturning, largeEnough, turnAngle),
(angle, newPos, ox, oy, oz, pastWp, wps))
->
let wpl
= case (pastWp) of
True -> case (not largeEnough) of
True -> (tail wps)
_ -> case notturning of
True -> (tail wps)
_ -> wps
_ -> wps
in
((angle, largeEnough, newPos, notturning, ox, oy, oz, turnAngle),
wpl)))))
>>>
arr
(\ (angle, largeEnough, newPos, notturning, ox, oy, oz, turnAngle)
->
let holdAngle
= case (not largeEnough) of
True -> angle
_ -> case notturning of
False -> turnAngle
_ -> angle
in
let legAnim
= case (not largeEnough) of
True -> walk
_ -> case (notturning) of
True -> walk
_ -> turn
in
(newPos, (ox, oy, oz), holdAngle, 0, noEvent, (stand, legAnim))))
turnToNextWp ::
Double ->
Double -> SF (ObjInput, Event (), Event ()) (Bool, Bool, Double)
turnToNextWp currentangle nextAngle
= (((arr
(\ (_, _, lev) ->
let targetAngle
= case
(abs (currentangle - nextAngle) <
abs (currentangle - (nextAngle + 360)))
of
True -> nextAngle
False -> nextAngle + 360
in (lev, targetAngle))
>>>
loop
(arr
(\ ((lev, targetAngle), angle) ->
let angularV
= case (abs (angle - targetAngle) > 3) of
True -> case (angle < targetAngle) of
True -> 360
_ -> - 360
False -> (targetAngle - angle)
in (angularV, (lev, targetAngle)))
>>>
(first ((currentangle +) ^<< integral) >>>
arr
(\ (angle, (lev, targetAngle)) ->
((angle, lev, targetAngle), angle)))))
>>>
arr
(\ (angle, lev, targetAngle) ->
let legState
= case (abs (angle - targetAngle) < 3) of
True -> idleLegs
_ -> turn
in ((legState, lev), (angle, targetAngle))))
>>>
(first
(arr (\ (legState, lev) -> (legState == idleLegs && isEvent lev))
>>> ((iPre noEvent) <<< edge))
>>>
first
(arr (\ switch2idle -> ((), switch2idle `tag` (constant True))) >>>
rSwitch (constant False)))
>>>
arr
(\ (ret, (angle, targetAngle)) ->
(ret, (abs (currentangle - targetAngle) > 30), angle)))
stepdist ::
Vec3 -> Vec3 -> Vec3 -> Double -> Double -> (Bool, Vec3)
stepdist (wx1, _, wz1) (_, _, _) (x, _, z) vel dt
= let (dx, _, dz) = normalise $ vectorSub (wx1, 0, wz1) (x, 0, z)
distance = sqrt (((x - wx1) * (x - wx1)) + ((z - wz1) * (z - wz1)))
remvel = distance * (distance / (vel * dt))
in
case (distance > (vel * dt)) of
True -> (False, (dx * vel * dt, 0, dz * vel * dt))
False -> (True, (dx * remvel, 0, dz * remvel))
playDead ::
Vec3 ->
Double ->
SF (ObjInput, Event (), Event ())
(Vec3, Vec3, Double, Double, Event (), (Int, Int))
playDead start angle
= (arr (\ (_, ev1, _) -> ev1) >>>
(notYet >>> arr (\ ev -> ((), ev `tag` (constant dead1)))) >>>
(drSwitch (constant death1) >>>
arr
(\ death -> (start, start, angle, 0, noEvent, (death, death)))))
getAngle :: (Vec3, Vec3) -> Double
getAngle ((x, _, z), (vx, _, vz))
= let angle
= acos $
dotProd (normalise $ vectorSub (vx, 0, vz) (x, 0, z)) (1, 0, 0)
in
case (vz > z) of
False -> (angle * 180 / pi)
True -> (360 - (angle * 180 / pi))
getVertAngle :: (Vec3, Vec3) -> Double
getVertAngle ((x, y, z), (vx, vy, vz))
= let angle1
= acos $
dotProd (normalise $ vectorSub (vx, vy, vz) (x, y, z)) (0, 1, 0)
in ((angle1 * 180 / pi) - 90)
updateAnimSF :: AnimState -> SF (Double, Int) (Event (), AnimState)
updateAnimSF iAnim
= (loop
(arr
(\ ((tme, animIndex), anim2) ->
((anim2, animIndex, tme), animIndex))
>>>
(first
(arr (\ (anim2, animIndex, tme) -> (animIndex, tme, anim2)) >>>
((iPre (False, iAnim)) <<< arr updateAnim))
>>>
arr
(\ ((hasLooped, anim2), animIndex) ->
((anim2, animIndex, hasLooped), anim2))))
>>>
arr
(\ (anim2, animIndex, hasLooped) ->
(case hasLooped of
True -> case (animIndex == dead1) of
True -> (noEvent, anim2)
False -> (Event (), anim2)
False -> (noEvent, anim2))))
moves :: SF (Double, Camera) Camera
moves
= (arr
(\ (speed, cam) ->
let (x, y, z) = (cpos cam)
(vpx, vpy, vpz) = (viewPos cam)
strafevec
= normalise
(crossProd (vectorSub (viewPos cam) (cpos cam)) (upVec cam))
(vx, _, vz) = normalise (crossProd (upVec cam) strafevec)
newx = (vx * speed)
newz = (vz * speed)
newvx = (vx * speed)
newvz = (vz * speed)
in
Camera{cpos = (x + newx, y, z + newz),
viewPos = (vpx + newvx, vpy, vpz + newvz), upVec = (upVec cam)}))
strafes :: SF (Double, Camera) Camera
strafes
= (arr
(\ (speed, cam) ->
let (sx, _, sz)
= normalise
(crossProd (vectorSub (viewPos cam) (cpos cam)) (upVec cam))
(x, y, z) = (cpos cam)
(vx, vy, vz) = (viewPos cam)
newx = (sx * speed)
newz = (sz * speed)
newvx = (sx * speed)
newvz = (sz * speed)
in
Camera{cpos = (x + newx, y, z + newz),
viewPos = (vx + newvx, vy, vz + newvz), upVec = (upVec cam)}))
movementKS :: Double -> SF GameInput Double
movementKS speed
= (keyStat >>>
loop
(arr (\ (key, v) -> nextSpeed key v) >>>
(((iPre 0) <<< identity) >>> arr (\ v -> (v, v)))))
where nextSpeed key v
| key == Event ('w', True) = speed
| key == Event ('s', True) = - speed
| (key == Event ('w', False) || key == Event ('s', False)) = 0
| otherwise = v
strafeKS :: Double -> SF GameInput Double
strafeKS speed
= (keyStat >>>
loop
(arr (\ (key, v) -> nextSpeed key v) >>>
(((iPre 0) <<< identity) >>> arr (\ v -> (v, v)))))
where nextSpeed key v
| key == Event ('d', True) = speed
| key == Event ('a', True) = - speed
| (key == Event ('d', False) || key == Event ('a', False)) = 0
| otherwise = v
fallingp :: SF (Bool, GameInput) Double
fallingp
= (arr (\ (lnd, gi) -> (gi, lnd)) >>>
(first keyStat >>> arr (\ (key, lnd) -> (key, (key, lnd)))) >>>
(first (arr (\ key -> key == Event ('e', True)) >>> arr jump2Vel)
>>> arr (\ (_, (key, lnd)) -> ((key, lnd), (key, lnd))))
>>>
(first
(arr (\ (key, lnd) -> key == Event ('e', True) && (lnd == True))
>>> arr bool2Ev)
>>> arr (\ (jumping, (key, lnd)) -> (lnd, (jumping, key, lnd))))
>>>
((first (arr (\ lnd -> (lnd == True)) >>> edge) >>>
loop
(arr
(\ ((landed, (jumping, key, lnd)), middleOfJump) ->
((key, lnd, middleOfJump), (jumping, lnd, landed)))
>>>
(first
(arr
(\ (key, lnd, middleOfJump) ->
case
(middleOfJump == False && key == Event ('e', True) && lnd == True)
of
True -> True
False -> case (lnd == True) of
True -> False
False -> middleOfJump)
>>> (iPre False <<< identity))
>>>
arr
(\ (middleOfJump, (jumping, lnd, landed)) ->
((jumping, lnd, landed, middleOfJump), middleOfJump)))))
>>>
arr
(\ (jumping, lnd, landed, middleOfJump) ->
((lnd, middleOfJump), (jumping, landed))))
>>>
(first
(arr
(\ (lnd, middleOfJump) ->
(lnd == False && middleOfJump == False))
>>> edge)
>>>
arr
(\ (notlanded, (jumping, landed)) ->
((),
(jumping `tag` falling' (- 200 :: Double) (40 :: Double)) `lMerge`
(landed `tag` constant (- 5.0e-2))
`lMerge`
(notlanded `tag` falling' (- 200 :: Double) (0 :: Double)))))
>>> drSwitch (falling' (- 200 :: Double) (0 :: Double)))
falling' :: Double -> Double -> SF () Double
falling' grav int
= (arr (\ () -> grav) >>> (integral >>> arr (\ vel -> (vel + int))) >>> integral)
bool2Ev :: Bool -> Event ()
bool2Ev b
| b = Event ()
| otherwise = noEvent
jump2Vel :: Bool -> Double
jump2Vel b
| b == True = 40
| otherwise = 0