-
Notifications
You must be signed in to change notification settings - Fork 0
/
backprop_functor.hs.bak
117 lines (90 loc) · 7.96 KB
/
backprop_functor.hs.bak
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
{-# LANGUAGE LiberalTypeSynonyms #-}
import qualified Data.Set as Set
data Learner aSet bSet pSet = Learner{
implementer :: pSet -> aSet -> bSet,
update :: pSet -> aSet -> bSet -> pSet,
request :: pSet -> aSet -> bSet -> aSet
}
data ParamFunction aSet bSet pSet = ParamFunction{
implementer_simple :: pSet -> aSet -> bSet
}
forget_education :: Learner aSet bSet pSet -> ParamFunction aSet bSet pSet
forget_education learner = ParamFunction{implementer_simple=(implementer learner)}
equivalenceLearners :: (qSet -> pSet) -> (pSet -> qSet) -> (Learner aSet bSet pSet) -> (Learner aSet bSet qSet)
equivalenceLearners f f_inv learner1 = Learner{implementer=(implementer learner1) . f,
update=(\q_elem a_elem b_elem -> f_inv $ (update learner1) (f q_elem) a_elem b_elem),
request=(request learner1) . f
}
equivalenceParamFunctions :: (qSet -> pSet) -> (ParamFunction aSet bSet pSet) -> (ParamFunction aSet bSet qSet)
equivalenceParamFunctions f param_f = ParamFunction{implementer_simple=(implementer_simple param_f) . f}
compose_learners_helper :: Learner aSet bSet pSet -> Learner bSet cSet qSet -> qSet -> pSet -> aSet -> cSet -> (qSet,pSet,aSet)
compose_learners_helper learner1 learner2 q_elem p_elem a_elem c_elem = ((update learner2) q_elem b_elem1 c_elem,
(update learner1) p_elem a_elem ((request learner2) q_elem b_elem1 c_elem),
(request learner1) p_elem a_elem ((request learner2) q_elem b_elem1 c_elem))
where b_elem1=(implementer learner1) p_elem a_elem
reshuffled :: (a,b,c) -> ((b,a),c)
reshuffled (x,y,z) = ((y,x),z)
compose_learners :: Learner aSet bSet pSet -> Learner bSet cSet qSet -> Learner aSet cSet (pSet,qSet)
compose_learners learner1 learner2 = Learner{implementer=(\tup -> ((implementer learner2) (snd tup)) . ((implementer learner1) (fst tup))),
update =(\tup a_elem c_elem -> fst . reshuffled $ compose_learners_helper learner1 learner2 (snd tup) (fst tup) a_elem c_elem),
request=(\tup a_elem c_elem -> snd . reshuffled $ compose_learners_helper learner1 learner2 (snd tup) (fst tup) a_elem c_elem)
}
compose_param_func :: ParamFunction aSet bSet pSet -> ParamFunction bSet cSet qSet -> ParamFunction aSet cSet (pSet,qSet)
compose_param_func param_f param_g = ParamFunction{implementer_simple=(\tup -> ((implementer_simple param_g) (snd tup)) . ((implementer_simple param_f) (fst tup)))}
monoidal_helper :: (a->b,c->d) -> (a,c) -> (b,d)
monoidal_helper (f,g) (x,y) = (f x,g y)
product_learners_helper :: Learner aSet bSet pSet -> Learner cSet dSet qSet -> pSet -> qSet -> aSet -> cSet -> bSet -> dSet -> (pSet,aSet,qSet,cSet)
product_learners_helper learner1 learner2 p_elem q_elem a_elem c_elem b_elem d_elem = ((update learner1) p_elem a_elem b_elem, (request learner1) p_elem a_elem b_elem,
(update learner2) q_elem c_elem d_elem, (request learner2) q_elem c_elem d_elem)
reshuffled2 :: (p,a,q,c) -> ((p,q),(a,c))
reshuffled2 (x,y,z,w) = ((x,z),(y,w))
product_learners :: Learner aSet bSet pSet -> Learner cSet dSet qSet -> Learner (aSet,cSet) (bSet,dSet) (pSet,qSet)
product_learners learner1 learner2 = Learner{implementer=(\tup -> monoidal_helper (implementer learner1 (fst tup),(implementer learner2) (snd tup))),
update =(\params inputs outputs -> fst $ helpered learner1 learner2 params inputs outputs),
request=(\params inputs outputs -> snd $ helpered learner1 learner2 params inputs outputs)
} where helpered=(\learner1 learner2 params inputs outputs -> reshuffled2 $ product_learners_helper learner1 learner2 (fst params) (snd params) (fst inputs) (snd inputs) (fst outputs) (snd outputs))
dot_prod :: (Num a) => [a] -> [a] -> a
dot_prod list1 list2 = sum (map (\tup -> (fst tup)*(snd tup)) (zip list1 list2))
make_nn_layer_helper :: (Num a,Bounded inputs,Enum inputs) => (outputs -> inputs -> a) -> (outputs -> a) -> outputs -> [a]
make_nn_layer_helper weights offsets which_output_neuron = (offsets which_output_neuron):(map (weights which_output_neuron) [minBound..maxBound])
make_nn_layer :: (Num a,Bounded inputs,Enum inputs) => (a -> a) -> (outputs -> inputs -> a) -> (outputs -> a) -> (inputs -> a) -> outputs -> a
make_nn_layer activation weights offsets previous_layer_values which_output_neuron = activation $ dot_prod (1:(map previous_layer_values [minBound..maxBound])) (make_nn_layer_helper weights offsets which_output_neuron)
make_learner_helper :: (outputs -> Maybe inputs -> a) -> ((outputs -> inputs -> a),(outputs -> a))
make_learner_helper both_together = (\o_elem i_elem -> (both_together o_elem (Just i_elem)),\o_elem -> both_together o_elem Nothing)
make_ParamFunction_from_nn_layer :: (Num a,Bounded inputs,Enum inputs) => (a->a) -> ParamFunction (inputs -> a) (outputs -> a) (outputs -> Maybe inputs -> a)
make_ParamFunction_from_nn_layer activation = ParamFunction{implementer_simple=(\params -> make_nn_layer activation (fst $ make_learner_helper params) (snd $ make_learner_helper params))}
after_curry :: ParamFunction a b (c -> d -> e) -> ParamFunction a b ((c,d)->e)
after_curry param_f =ParamFunction{implementer_simple=(implementer_simple param_f) . curry}
make_ParamFunction_from_nn_layer_curried :: (Num a,Bounded inputs,Enum inputs) => (a->a) -> ParamFunction (inputs -> a) (outputs -> a) ((outputs,Maybe inputs) -> a)
make_ParamFunction_from_nn_layer_curried = after_curry . make_ParamFunction_from_nn_layer
--make_learner_from_nn_layer :: (Num a, Bounded inputs, Enum inputs) => (a -> a) -> Learner (inputs -> a) (outputs -> a) ((outputs,Maybe inputs) -> a)
--make_learner_from_nn_layer activation activation_deriv = Learner{implementer=implementer_simple (make_ParamFunction_from_nn_layer_curried activation),
-- update= --TODO
-- request= --TODO
-- }
data OpenGame x s y r sigma = OpenGame{
play_function :: sigma -> x -> y,
coplay_function :: sigma -> x -> r -> s,
best_response_function :: x -> (y -> r) -> (sigma -> Set.Set (sigma))
}
data Learner_ND aSet bSet pSet = Learner_ND{
implementer_ND :: pSet -> aSet -> bSet,
request_ND :: pSet -> aSet -> bSet -> aSet,
update_ND :: aSet -> bSet -> pSet -> Set.Set pSet
}
choose_ND_learner :: Learner_ND aSet bSet pSet -> Learner aSet bSet pSet
choose_ND_learner learner_nd = Learner{implementer=implementer_ND learner_nd,
request=request_ND learner_nd,
update = (\p_elem a_elem b_elem -> elemAt 0 $ (update_ND learner_nd) a_elem b_elem p_elem)
}
learner_to_game :: Learner xSet ySet pSet -> OpenGame xSet xSet ySet ySet pSet
learner_to_game learner = OpenGame{play_function = implementer learner,
coplay_function = request learner,
best_response_function = (\h k p -> Set.singleton $ (update learner) p h (k ((implementer learner) p h)) )
}
learner_nd_to_game :: Learner_ND xSet ySet pSet -> OpenGame xSet xSet ySet ySet pSet
learner_nd_to_game learner = OpenGame{play_function = implementer_ND learner,
coplay_function = request_ND learner,
best_response_function = (\h k p -> (update_ND learner) h (k ((implementer_ND learner) p h)) p )}