From dd7f1e1627cf8956371b37c9af0e490e3f91e146 Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 12 Oct 2018 14:26:06 +0200 Subject: [PATCH] preparing controller adjustment --- assets/icons/arrow.png | Bin 0 -> 14580 bytes src/Init.hs | 2 + src/Load.hs | 15 ++- src/Main.hs | 3 + src/Menu.hs | 75 -------------- src/Menu/Connect.hs | 224 +++++++++++++++++++++++++++++++++++++++++ src/StateMachine.hs | 8 +- src/Types/ImgId.hs | 1 + src/Types/StateData.hs | 10 +- src/Types/UserData.hs | 50 ++++----- src/Util.hs | 34 ++++++- tracer-game.cabal | 2 +- 12 files changed, 306 insertions(+), 118 deletions(-) create mode 100644 assets/icons/arrow.png delete mode 100644 src/Menu.hs create mode 100644 src/Menu/Connect.hs diff --git a/assets/icons/arrow.png b/assets/icons/arrow.png new file mode 100644 index 0000000000000000000000000000000000000000..d787ec1590a8d4fa27c5db626cc9233d278c6533 GIT binary patch literal 14580 zcmdsedpMNs*XSUWW=!+SnNg&}ID~OZhGdYDLNjv6VaSLQCFPVu-ZT{{8NEZH#$*hk zq$p*IQW?}_@+N6gDLNP-Bt#z;STF-HhEiNbp z4Fv=OfpXnM^g7Yzick{WsOD9!gR*IcOeEOs(I%s?DiU@17(R}7q zKmS*tamU)~8eb?Lr>zEC0v?3qtJX%}? z?e1FqA>7RLD%V`1<@DtagI6w^-|d+VhX&ucxaOLBG7}hlTW-vf@ecxiawsjZd~CR) zbf5S<&h^610aV&nshb7_x6Zo@ZB2Ajyb_nV#^JduqC9DR3#}Og3&u=;qJyjHlY0jp zRtR@j0Mj&X@Eg~OWglvi5ms_{PcuXPkDk50!I@EN5jIf8`=hx(3U&$gB ztj>sh4a*f~+|os697|X}AnVL9H*ZK1O5*t-(jmZ__3CzgJ4|7yn-_m-e7(@+voS0A5 zchBt^{J8F98TteGu{d`p% zvR|G}c*Fu*l&(?+rB+1kxV>g(>Chr>rwrO>tA`Y^1)X*$?cCV9uJd0I=ku5oIAH(O zem04_g~hN##Q6mQDV;$bKNSkD}!Ugv1>k(pFn@koc86XB5D94T}*{Uk{dgPF^eECa$Q zAGX7IID7t>b?w7%$4Q-n^rXtt6AfPaDDqKRw4emkz_nnz34woyH_n|T=ul7&b zc6q))sLz&XQl^s*YuG8|b?I&AmP!FdeKNL<4@;!!^i;O*)t|0|zBVxrNZda?^_9J; z9(OdYSLhlW5gs{Tr^c-X86}ugp7MG>}uBL)RmrJx>5b3BczLK&j~z zJvAGd*w+yO&xgIDM3joAnM)(3pq!Te&shQ;E0xVjkEGOKp*YC?drltW)+wXe# z7G%Iq3(UxQ*y&5_lbh6vxgw}NAaeVQExn^WH<9L%{rsA8MNl3fx4p7dIty3s0#Ht( zxZia9b$|<3?t%Pl1uRsZTHM^wo-BT&Q49|Fd>u4w9GH>lKx}LrTVjESy*tUSnq;a6 z!Cp7eGm&m;Qn|t?9F{z&9y4LY#%p6sLPLC9{X)pDpC!B2>IPC^*AxCLsWMQyvou)u z@b%D-AriHG6HlA&ZXP0w3fSR;yqeqr9w(P3d5NIg=aYDPjY(x`1XvAq;Mmq|y45-C zP7>IZTY$cVHDdZ?p&(=P8L$IqJ@w<@d~Fp>^cupWys!bC=X*eYN{_=88G)1({eg)# zBGBRGNMJV}2wmmU@`{AM>}+Ag+fyh7c^F zsF2Sgax6HR2D*0@zexS!ju~q2L2DJy+Xu2HNTV_i#hqYaiT?S_n`H@0KY?m(bY@)N z41)6)JwA2Nq3Z%wKl_}gejOa|;?g1y$G=qf7FaiwkuE(cNz8MgfQQhi(GeF)?hb2E z4l-_@0QaP)*Y5~uJq#PTkbX9;g7NznjZC=a5t666{htIG9Q#a$Io6r6(g1%*c8knG z9KlUqRSJEIzBLa^oN43VmR=>@v@J1TF=g==O-#^g0^Qskc9&mM#$`lGn~fTq8+cp% z$uRI1;IeS;TL9@2`sB_*2lLcS2HA>5Ive5<@d;^A9tbZrmv|Y$k6Vhiv0Y6#^>Y??(T7zJGKl5epO}*;^1n)C&)P82bnU_ zJq4b0C>&l2A(uzWF)o7x%WQ78rx<0BZhc``Cdo9d0UYlNoLK`T26v~2>$&bKp9>3j zT!Fi;4`F+namjG3A6z3Nj9iYBV_Z)F=A80mN2-y%te6Sm1?`_R84@qfl?bC2rr4N3 zzuZ=ntJ294h}6k~pK9KM5J28MgVdweO!CuWkut(OTxUSc9>8sGl4EpL^BV~<3jYWn zSsylpdbo~)=N<*>Jdn7EyCAVCSvZt4_!|$RR#4)S2ydWL2h2bQ=v6?P1N($iOLrO} zEl46LLH8>o>%G|hAafZgTz0yFw^vgZP8m)OQ}^~tg&!p*cqyiM4T0Wu)3VZT@s3&` zSIt|)kVSG*BMWMFf-+V50NZWUDSp-&B#o8LfIW+}7+^Hhd|W?=lOw1|T)85UZs*KU zxpb|>23?;@JnxsdqJso;Vqy8+KBwE+-&vT*GT2Yq3CP3|o`*W5}D+)pN>D;sv0 za7y<*mKX^z9=pxBUF+ebRd7<{6%x8+U%4Tt<3UNT%}IJRVnQm#7X%rcV<$fe6z=(3 z5+iY2gva5kv1MLS;7Pne#1g3pFwfUi*j*06mbu95%C7uc{! zcvH@bs8dw-8a%g)>7ZY}xS6yK1mi5fSJ@i%cR8@}ykqQHTh`bz0h#jSkAXMR)6Olb zp!T;CCd+O}y#7&}BawsKQo!&N3$D>8ZDOK_td|{-7p*`q6goF}vD?3&DK5>=yFf#S%@jZd|_i6-&S-619 zf|C6ScU_nXOT@W?SmY)|r&;CC=b1t*$i{LOX#=BmWp8K6(01CadJHm#EvQ945)i)o zGN-zoR;ix>H-`Gv27QHYlhBH*;hwa+EC>fW}`28yT$R0y2>BZAwJ`r8FC2~^qaeq zd%xsXlY_9BpJj;*3;@Xf29~G_th%?xVpil4Fvy(@>`p_oSObwZ53_q_yNY$k)2O|& zo%6s=0l>qOf*br^jd*m-ra@oaRd(y8OiB*YK-j@4SdtOhV;1W#(&Mp6onB{*liHCI z$XuqU1q24y!v=ov%F<=rI=z@xnv?T~av7c$QuB`#%^m8(0ibzXneOjLXFM(T!=t+4 zk@d=d-x)Jx6pV8gHFI4u8Ihsn?7ti=qL>K*BBbclQ5UAh@AVLJHaW~84l75gHXF_4 zsiyf?e@yKgwYKmdzR3BF=6#OFatWHF56x3&t&9k53-`P)P5AwKFgbfO+aWG;(BYvj zK3Xan^LN9Tq2ASJ-4klw1hY!>1I|La8u>YREBTHERY8gQn89}!=<{$0poazRbNps#afb!%$d)an`+%m^wNJ+#n3NA}ctPs*Bk76ccR z+#&%Y#y~>;QQ=xQ2ui6IA41wtyeXjyz5kvgQLV_K_^^lX)(r z$|WQIzC32AWZKD*Zsu;!WRUP&T!@FeKMgD0sFM+SW@)tP#>>^2qK{k5U7RMb zL7sWccTB%o``56q{mjkBx|bA?6@lvBxCb2WhIs>>e0gkH=ow}wqVL3;YJEc-msc~y zptApHbVZ++Tsnw*wa=HJZ#_GoH4V=*->AUTB6yzpwdvh?MWOwqmdbg~pWI1C<;}n2 zB@(hfdR$fBIDgYB4>%gjG9qu8;mta7~rB6v={SsBKMC_V)6n;Zzrw3ZM-!S;lkk8c~DeK3| z6;#b0RH&CEyNQuFywj#|UV08fo>AmfXpsjZL3mv=l#?SZT*cyo*52wV`MJ6#6-2?w zF$=fr{tya6Ww6bMO}PpjLymDv$&foOP~BRk9`;x^>nU5RN0Oy%jqq=trtBwc?(``~ zI}49MxFN4jp7Bv3PZ$wSI=_qH`J*aQ)VzCEvm(=x+`%XOuj%j7XMo$xt|bP?q@(eb zKd%~Arci)3WJS6uSEZ$-pvsbSij^?&*N~SR$5yJD3pv1xHjW?SH{ZoSMx*+ zJ&CSgXEJ}tmeHPzNqI$1cQ_VYp0Y%Ehwew;C{ias7s?4A^B_OJ)Yqj&LFBa73}sW< zMkAV6TtH^R1}xG#r4JbrPF}zNE}ey(XN^|VN zLEo<1J=?kYwu%!z~w=f4z3S zCVOMT$$=0XENmQMp@?MfXuVl!DHf!v@S(D6t9h!DX(|cxDbEJ+aRbp-myFa!> zUsk8wS~K&fAS26x7N}~iJjsG9q&`f^Nj4YX&4 zCCEqcjNCde9o6{!uIU39oi{Z@E}GsJS9~NU&zT}g*RaCn>^BuFI^S9e*3f} zQHbXiY!TK?zn=z^uiT%1YOvXYTe7GEtuDEwZ6=k@ogBa4?^XP@AGo>1x(A3NCg%@$ zmQXFcoP}odNclB)u@pqX1vR(4z+ElV-6E&RtI^PBal_z7riausNEN1B4f*G`3g(rG zOE6GN5i~mQ`Gl-cR|7rWM)PpJ&=4YI(XBDfkq1`lPyndWVy-_(LdFM@@PqcBRAJ$d zJC$fzV@Y0=Ns&K$3ep~+Hf|?5;F$x@G?QYl+plC^y~wQ6Iry3<1@eVQB}2y?*l<9_ z`X!S@TA;*OEy3uN`Ch$MKTma`>0^$hh=ng-#ZiPr3qlQ~+33Ws*)J$=o%$a`A@<2j z|1P9ktHdvekrXEW##$Ros(Fu|ZZ_ujD08<-ieG|z0)^kI`c(mh*WIntEXFr6O^Vq| z*zYWlC_eCjtAp8x9RDXl5`J(W%6zLJJV2@67`OA@?%Q6JzEni9A%W;JE%AjPA_3(|W4Vn(hB96y;o@cydXuPeI8YjtZkVI2l}Qo`uSVbMGMz|{3N z_Gug@gSB8Vo6yPWw~h>bU>|!LbDcWAO!OCs)^)VIPXK!!tKkPV+$S6s_dbD)Hs}0& zCMO)^xdR8D#mX-we=FBGO|M@NzanN2u&PIXlAa_nh^dRUNZL6cRyDOoUiYL7VsV`p zha4a|{Y8(D8(f}W{&s+{rVT5Lh1l=ZH~Hiz$`vWZmi6h5oX`i6f}~1kb&9gx_oNyF z@(jnEL)uH)uHU0v;eyZsF>pzG$Kv%7TW+VX@@Pd9&K_QBeT&02=R{6@8Y=;*N{#S{ zPyyH)-bza`!}n`6u6sH$94rEu2{J>Ax!d!x8^?WBymbr#5@=qJOS;9^s|94A?3G-I z4NjVH5+Si7be0I9_B6hFNTFiuyy0S{>5)30JuAH*x%5Azto2$+4;v)vcd2BdFxuDW za0&eW^(aU!-TIIC#KCno1)F^+^KuQCby{$`$}B6f?g7*fWztE4Od(zZbH#n`5GOK& zdn1;E{I-&TIhYgX-Kp&Uo>YC{Fhlt*G)rQnr zwVx0kWXr2((Bn~JRS7Kl0_6(7z6UmEaV#9Z+9|f?qmHELq%$?nx#p6x$o9%5WgKPC zOBQcJ70a$5MEronk^tshx`>i^>Qoi#{9jB9!xQ|{Tb#%ysjVfaCK}YqgeQDWuTH(D z1w~j)v?1Y<4f(1~?J~-h9;2kCK5gr~f&04salDgmzyo9RoOG9Q8`jVzg?N0-F@fWO zV2^Q0rj>1joie)OAygxK_-^|2J^w=J_+5#3uCi13;!bQ_5FY_dzGYy-eHX?(!R05f z7S{`6=U*1Mq(nmv_;LlRqSb4w&sT@hyY&^oFQjh26R%CecnmY)jlgk?T>$2wP-b{F z!9`w9A`vMTvchdB9O~Y+nxD7fumgug3z|WlM>dvZb_dIfzwsLb2OWNTIFZ8!UYM_v zpW8C%dxLjYkd((v-4Kw(Q9LQBd6mk8ZXAc}b|DmY51&ess9&dipnu{i#VVO!?t{xE z0Hn4`?+r?%8~G@3q2RL<3FhT_nkEz@GZrZ3&~HM1=@;>`OnNsMFLXPLr!Dain2|jt znU2TMeEuCb^i|J{94`M?KxWfmN6FALxU9N8Bzs$3=aFss57+1#vpZbUGbs?5C2T;s z+-|hPSCbRz*=osTscM-jCpD~xYxW`q4(~* z4d|53oIU>DAF*`}p~V?#!!?Ul6+;$FqP-Y4)<-&PL~J0A;_sym<`I}a5(&dJ`c)y?<7hSmc)sS zH~j(j-y?dXfZs##K8C3KRT6_PAb304*T#r@YHae}R(UIqy9#M2Gj19bsJ184m5rsa zSWK(rmhJ0Bb3?U>Cy#=r(2 zokJY7;{5cC@IZ~1t&3>JAuDb}Mty0fHdVJdX=%L?#LdfT7WJISAXj{8czG-0<_S7} zJ`zg^Eg+CB7C@PFIn>UAeSJ`0*LK(SDoWcNhKb2&fN4>2^C3^It3} zD5-_RidF8;ZcTT&ITsv}(NkihT~7rERKGNS2eI)c6qF*Au}g*q#*2t856oROlCO^$ zLQIS{IqBd;neOKcT-Io*V47CjHm`;vHPnYo-SZE>@7pT7WwWL?T832I7XSQyck$zr zOA7Ui!h(Vmy@|++{EBWlp?ViaQc*rmZ-T0%xp|wNvd?p@!5ihjGwAgT;}^zw-!nb9 zCjKiEWy&QbQr>>f*+~1gQHgA|+Lom1<^aYkW0NE0?ZEhLNDD5ZDsoe;0wLHA5dXxh z`;i&HI5TsIR^`Uo)!+wg;$(%V?KT>s1Yn3H#pUaonUtU{h!l$Wrxgy)KpJtYyv04M z;*;+`yuQ}Ojsd0Ft5A##(DXj`{QTSPGM!h49H1|iTqjzn|0;N;<4JCAw2nPXR9Ddr z37xC9z2^>TTL@xz;~J_xWx6wk&pE3qzbPc!;N50t%;es{A(7si*k1=%eePV9=#PwbUro>HVdcgfo^@MZsW$#dRc<_3XEr)u?l3-m)Mc>$ z4-p14auF!6gRa3K?+g_2J{3W5>iIp+^dG!VDg-7K9_g;~(j=Ejb+3hJ@7z_*+HNbs{N%+Y>7>`$}3{AZcDY+9doa^ojdU}H_Akb z6?yhzGrGhg3iG~uT3j$B63RW-S1(txN$%C-P=99 zfuL!8@)7^lv-6IW=D{1_x{=(MQ;&8l=^X7?ty{DRIxU5~7&TugJreUOz~EtDQHOH_@#Sl)4hkMdvwe$@md|@9nWA z?41LIG^KQnKw=_Be41_zfpl&au+Nbo|L3>IEzLN*jJ1L_XUq^;w#Y_3gnYp>G3|vn z@7SxYjqW7cH^uWCUMd~9?We%aIfo?*dU|9w21z2CAD3Q+S~S!|=KK|phKQo}=^n2+ z5?EN%7S2zFn3Tcge%o17gZsZy>?oCEg|uuG9%@pe;s zTtw5w$VJ@6=}-fS4c)XSB)9`QfRIH%l+>d%89$#6jpj1Z(sokFHQ2SX-1UtK9M3r0 zn1h4Mz3a8b4Im!oBg~xxcX_R88hbTV1(hC@38l?W$m8xv{<`Dzk1}hG;Bux-1j-fs zWHqsahy)(#kt55i?h+)i%g|g;hR;G6`#4K70f`Wp;UUZWt5VG)`51-InSm zr%AbT4&ST!D?7b2d_V_sMDMS;!}96_xx*w?guGLWhfGpd@~^U^C+XdYwZ;;0mCSG*m(3$Gzd;D~`Z)7_5bpGIMq+t~rPrjY~^IET$ z2WqNV%9U`Oeh#q~2XH22?EJR*)D7>Sv2LFA5S+n`doMVUx%CnlqV0+6yFkDE1vMfrJ^sMa#_EZbZ%wk;iZ#bAb`G(Zh!na0|gzF zMeP@R*5?<6EruxGF_8H3(mfZ-=Q>^!1SgBDkXmP%IS|@I`9EYR!R?nUZ&r>W7s5%h zae@Bv;>HpQe;s4zbb47lexsClUBS%^U_9=}ffOM;QT_$^= z2_{^s(+~o9f2rtpet4diE?y7+24P$AUJLKj;~3@ zbP1=M;utILK`TI1UST#WcG|HTe^bhCL+xCp+{b5?9v61N^*5_xsxKG4Q&C(nYm8U@ zv9JNfJ)6FM?NEWHxR`fXufJE2F;;$yBfaa*jytO2T8Ss!NwZ5SQr%@A_Z=fzKH9h? zr-S8t@#h}Nd=iVW_hNoc;_8~yGj+^_C>Sz1w4-I*@>4f21vA0|P*fvX>!)M z75KbmX*WARzaRghP1ccD{HwLQID-u>YLbADTi-eaVRWbM+SAPSGC^{Y@wZ!LdG|1$ zZI(q$vL*$A8L6m;e} znD}QYj;?;^>G6d5oHuyAsGi@ryEw=kk4AJLs$PBUzHoMNnoMg-P3*WtqUJW#wsJFT zY|QaN4bRr*GP_G&o{pc$&bhwiqx1xxvtoRW?(7Mh4wGJtwLX5h>Dk&m<}2F38QxXo zbU=!mF+#E6{_Pzu7zs+k@2kZP%&A#^FO@L&j^BGG(eAC3yT@yLUAygYbMKTesVFT^ z$P90=5~M~oyQfKo{Kn<&LtWd--^KK>T~b(RoSG-uAudN+NAWy^i6`9J9kf11F6LMQ z(n8+NfDAd&`?tjmI^D{n6Ed)_Tp@o@wMJ?1H2u@xHLm5A8|lOePeGyL## zY;Pl%--wS<5vz!XPHMzttb|&3LlgwoXv_$j*SOnm2$?sd!r4Y9W97|)4k zk*@i4kMkS$)8x7M-e6=&c@GLYUX;@`DyLPM5ujT1@6gnP_&Aee-9j z9Ag3zy|V6DB>Nd*)_?CyAOS0T>cKkRT^K{yRA0vR!i*d&n0PW3UT=N&m1CWN!%{GQ z6&e>kG)WHrns3QYg_PH8Yozaor#Rhycb<}Ir3zJGKz4K1p~SpAA?c%zUcbKPwM$B_ zoStrj(DA%UPaE6t(q#A7FbLx4Utr3_W!Xj*A`zr?S3 z1q-@VC^J}WtLcG;34Wy}bhaP{>=Y$tf!#twWJnPh<-{`2MzHOgnO__s5 zgl8h6{5pNo|MJa{IJ+2NL5j0b<@&y>>&2sjT0`F2h$BOlFfFq>$ols2^mWv)Cxp#u zP&vAWXp;S=gINVpBF&j15A8A0H(m~@)6B(Q_M18;2!@ANpqz+WGFl6FcqHbp`?)4& zf^H3U%{n~S<^(-e3cB4jV}`Nf!@)P{lVyU8T}yUcc-cZ(kHHknDPHnzS1(MJ`Su6q z&1%9UH8lzz=GA2PqR&GbioLM#R|GK`QcVq{B&^wnAhv|3*-PDpk|y@Bbp1ABaubwJ zsO0w5x+xB|2{Y@u?xdThcOxdU=|TBe=iE$V-C0zJ+k_Zz?NC>O4Pz)>-@ zg}%F!=KpkVI7#}A^cHzL>Et!KJEAx~v_Q?(<7Yn<>h+5^c4PDSzZBY8GfvZ6h`o)x zI3Y~VnYFX-$)qJAto~{a>yWuCovdPQqnl!KY&VA`F>nXJmVNHnlX`}^{@MAClyDJ^ z=bm;U-Qdu#T-B$^iNi^}LuqSeg6Q-$jm|E)Tnt7Pp%X3H{k(T>cth-P)1ny1;LoRm zzV8v;HlLV_mMNC+h^%HwnQ&Dq4_6)DGrhQekHzPoyi<}<>@@A3xyhU6I^Xnh-nI|JbFXB&OA;DJ63my!DT-rLPJLrdtxxz z)$cKZl6xISOINshq5o~imG?zBS3h|cDR)J={J-t+-oKTx;tC90y5@Gt{Al>VRhmNH;K)%7!=kh=n!TK{Q>fb^|Aw>0iwNdAvIBJ?N7 zt^%+;xz}&3CZv@n{vQzZA0%fF{oj!Mn{8Jh-E(hrAr0|0Ggtg~datx6m6moiQaAZM zZcQz$_tG!N16N+a5T#_OyR>~RG@#_doXv`eC}&1#2XGvCbXbW+@(Ks8 z{R@hq2gX4qcjvkr_QnAi$wd_ct-s&x)6W^G8Zp*VFP3F8>vZ zpa)L80MqAif5MgjODO+ai2D^zY;wJj(0uxO?niP||Gy#fKLKITP!_2Kq9`HfUx-|{ z{CC>tDg9q_@V5*D{>rDBc0bRW1MgsvY{pZtxiMmsUKe}ZfQMB`0? z=W%^H`t2=+aB&@s|5$=+U`nLPW;iF8*6;2pAnheb!|{^AeAvhN&){4uMrT(?tn4#i z0ouXMgv+GC0Igu?Unl%maNo*duUrdg%T_~)lf zg)q_mKSwx%9SgQ>$v# zTO63QiR8?XuOTVJhX7QYYEfM@Mcm`)^?f#e@4ek_eyiXEg3F_6ZVCa@fk&&>n*+QQ ze{oOl3mDdxTdkYBU-Mz~Ip)nZ2fi+EfFhkH#p@`{@Ya)36owhH)d4$b-xfAr5-o(m zb{JICsG5WF<6-=0&5`c4EAiDxt;N3r@0pTjU;aL*Y8VQ@n)uNvW`q0NbtEJNM>$9VN{@(BQSD!D!35v{b3PvdNm0)Z4?mmzu@Oix%+~r&Xw8<)6#} zJTPh+Rl|AMlDOI*-TRx``KhwAN|UByyr_(~HEk|pZbqN?(mdRF#zxopYvMhABd#WD zI=Xtnmzpp3cjaE&F%My5?8FA5U-bGff1Nlu9u*G5aYejzp72)3O@!lA?KyLqt;l>i z9R85p?42N651rS*|obKIXru~9h=qD0z z+W7S_qXT4{D#toPQEIA4j)+CrquYvhVgkSx0Ftrhf=coK>f!Q>@$sg?S zXB&SVCib$&mgK%@W#A%sy8Twr4DP&mG$9(kptw?OKoRi52EI+I#VB;hSE*vcB{i_0 zAf2c;>gMv%k-c^>OdA&q-%xCz*{NAy9@8o)Jeg*nMIWBu2tp=&tH-l)Ltku2D1-6P zP6n?04`xEDXd8?<4R^@yRl&?vOKN%#B@ZzBv>@1tPP7uGfwFU%!5B6wz#BOF^U{Db9u`#BX=NH9m?_4 z7Y;5IO$r=$y$)Q8f%fp9r719%%_UC<^43b-&M$JpPc0MECFB2_hRzvKyx2Vx(tYv} z>D6*--=(#}aIdvG#p{7?e;MQ)wJ<$mWTRodTGto`txKmQr#iJ%r`_3QS5!?+l!r2M zeLc`KAo<3n_2K=epU%`t?|A+N`=vO+!oRA7cL6^=@FBT_;@33f)EyI|z zt5PmgN(-U2rFNL~Id-{tp9qC{t4_^D!1oE2{6>8Uov1tug`90Cb)<(E^nD1mb2R{A zYJrX>??U>tpfcojw&Mi7I8WQv%Lt5ye;%_Nq<1DxJJ>};;wkbd=}~R&R%c_=7w*H9xwH5idOoJgfA2ku1;HsRU3nk{5OZ*qHh2I literal 0 HcmV?d00001 diff --git a/src/Init.hs b/src/Init.hs index b817252..0a97706 100644 --- a/src/Init.hs +++ b/src/Init.hs @@ -47,6 +47,8 @@ init = do , stateData = None , threadContext = Nothing , joystick = Nothing + , translation = defaultTranslation + , joyCache = [] } loadPlayerSprite diff --git a/src/Load.hs b/src/Load.hs index 5413828..e85eacd 100644 --- a/src/Load.hs +++ b/src/Load.hs @@ -20,7 +20,7 @@ import NanoVG hiding (V2(..)) -- internal imports -import Menu +import Menu.Connect import Types import MainGame.WorldMap import Util @@ -63,7 +63,7 @@ loadFork -> MVar (Float, T.Text) -> IO () loadFork ws win glc nvg future progress = do - let stateSteps = 37 + let stateSteps = 40 increment = 1 / stateSteps SDL.glMakeCurrent win glc modifyMVar_ progress (return . (\(p, _) -> @@ -76,6 +76,11 @@ loadFork ws win glc nvg future progress = do , "Loading icon \"conntroller_green\"" ))) mcontrgreen <- createImage nvg (FileName "assets/icons/controller_green.png") 0 + modifyMVar_ progress (return . (\(p, _) -> + ( p + increment + , "Loading icon \"arrow\"" + ))) + marrow <- createImage nvg (FileName "assets/icons/arrow.png") 0 modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Loading asset \"wall_asc\"" @@ -202,7 +207,7 @@ loadFork ws win glc nvg future progress = do ))) mmiscWatercooler <- createImage nvg (FileName "assets/misc/watercooler.png") 0 let micons = - [ mcontrblue, mcontrgreen + [ mcontrblue, mcontrgreen, marrow ] when (any isNothing micons) $ do liftIO $logIO Error "Failed to load icon assets" @@ -234,7 +239,7 @@ loadFork ws win glc nvg future progress = do mimgs icons = zipWith (\a b -> (a, fromJust b)) [ IconContrBlue - .. IconContrGreen + .. IconArrow ] micons directions = [E .. N] ++ [NE] @@ -376,7 +381,7 @@ updateLoad _ = do , assetAnimations = loadAssetAnims ld , assetIcons = loadAssetIcons ld -- , state = Main WorldMap - , state = Menu + -- , state = Menu Connect , stateData = None } -- loadMap diff --git a/src/Main.hs b/src/Main.hs index 4d6a9e8..5fb265b 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -22,6 +22,7 @@ import Control.Monad (when) import Types hiding (draw) import StateMachine () import Init +import Util foreign import ccall unsafe "glewInit" glewInit :: IO CInt @@ -60,11 +61,13 @@ pre = do _ <- partSubscribe w exitOnWindowClose _ <- partSubscribe k toggleFullScreen _ <- partSubscribe k quitGame + u <- partSubscribe j cacheJoypad (ws, _) <- yieldSystemT (0, defStorage) (return ()) putAffection ud { threadContext = Just threadCtx , window = Just (drawWindow ad) , worldState = ws + , joyUUID = u } quitGame :: KeyboardMessage -> Affection UserData () diff --git a/src/Menu.hs b/src/Menu.hs deleted file mode 100644 index bbca091..0000000 --- a/src/Menu.hs +++ /dev/null @@ -1,75 +0,0 @@ -module Menu where - -import Affection as A - -import qualified SDL - -import NanoVG - -import qualified Data.Map.Strict as M -import Data.Maybe (isNothing) - -import Control.Monad (when) - --- internal imports - -import Types - -loadMenu :: Affection UserData () -loadMenu = do - ud <- getAffection - ad <- get - let (Subsystems _ m _ j _) = subsystems ud - uu1 <- partSubscribe j joystickConnect - uu2 <- partSubscribe j joyDisconnect - putAffection ud - { uuid = [ uu1, uu2 ] - , state = Menu - } - -joystickConnect :: JoystickMessage -> Affection UserData () -joystickConnect msg = do - ud <- getAffection - when (isNothing $ joystick ud) $ do - mjoy <- joystickAutoConnect msg - maybe (return ()) (\joy -> do - ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy - liftIO $ logIO A.Debug $ "Joystick connected: " ++ show ident - putAffection ud - { joystick = Just joy - , translation = defaultTranslation - } - ) mjoy - -joyDisconnect :: JoystickMessage -> Affection UserData () -joyDisconnect msg = do - ud <- getAffection - maybe (return ()) (\joy -> do - njoys <- joystickAutoDisconnect [joy] msg - when (null njoys) $ do - liftIO $ logIO A.Debug $ "Joystick disconnected" - putAffection ud - { joystick = Nothing - } - ) (joystick ud) - -updateMenu :: Double -> Affection UserData () -updateMenu dt = return () - -drawMenu :: Affection UserData () -drawMenu = do - ud <- getAffection - liftIO $ do - let ctx = nano ud - controller = joystick ud - save ctx - beginPath ctx - paint <- imagePattern ctx 600 620 80 80 0 (assetIcons ud M.! - if isNothing controller - then IconContrBlue - else IconContrGreen - ) 1 - rect ctx 600 620 80 80 - fillPaint ctx paint - fill ctx - restore ctx diff --git a/src/Menu/Connect.hs b/src/Menu/Connect.hs new file mode 100644 index 0000000..8d5a4d5 --- /dev/null +++ b/src/Menu/Connect.hs @@ -0,0 +1,224 @@ +module Menu.Connect where + +import Affection as A + +import qualified SDL hiding (V2) + +import NanoVG hiding (V2) + +import Linear hiding (rotate) + +import qualified Data.Set as S +import qualified Data.Map.Strict as M +import Data.Maybe (isNothing, isJust) + +import Control.Monad + +-- internal imports + +import Types +import Util + +loadMenu :: Affection UserData () +loadMenu = do + ud <- getAffection + ad <- get + let (Subsystems _ m _ j t) = subsystems ud + uu1 <- partSubscribe j joystickConnect + uu2 <- partSubscribe j joystickDisconnect + uu3 <- partSubscribe j emitActionMessage + uu4 <- partSubscribe t handleActionMessages + uu5 <- partSubscribe m handleClicks + partUnSubscribe j (joyUUID ud) + putAffection ud + { uuid = [ uu1, uu2, uu3, uu4 ] + , state = Menu Connect + , stateData = MenuData (V2 0 0) S 0 + , joyCache = [] + } + mapM_ (partEmit j) (joyCache ud) + +joystickConnect :: JoystickMessage -> Affection UserData () +joystickConnect msg = do + ud <- getAffection + when (isNothing $ joystick ud) $ do + mjoy <- joystickAutoConnect msg + maybe (return ()) (\joy -> do + ident <- liftIO $ fromIntegral <$> SDL.getJoystickID joy + liftIO $ logIO A.Debug $ "Joystick connected: " ++ show ident + putAffection ud + { joystick = Just joy + } + ) mjoy + +joystickDisconnect :: JoystickMessage -> Affection UserData () +joystickDisconnect msg = do + ud <- getAffection + maybe (return ()) (\joy -> do + njoys <- joystickAutoDisconnect [joy] msg + when (null njoys) $ do + liftIO $ logIO A.Debug $ "Joystick disconnected" + putAffection ud + { joystick = Nothing + } + ) (joystick ud) + +handleActionMessages :: ActionMessage -> Affection UserData () +handleActionMessages (ActionMessage Activate _) = do + ud <- getAffection + putAffection ud + { stateData = (stateData ud) + { activate = 0.5 + } + } +handleActionMessages (ActionMessage (UpDown f) _) = do + ud <- getAffection + let V2 vx _ = velocity $ stateData ud + putAffection ud + { stateData = (stateData ud) + { velocity = (V2 vx (fromIntegral f / 32768)) + } + } +handleActionMessages (ActionMessage (LeftRight f) _) = do + ud <- getAffection + let V2 _ vy = velocity $ stateData ud + putAffection ud + { stateData = (stateData ud) + { velocity = (V2 (fromIntegral f / 32768) vy) + } + } + +handleClicks :: MouseMessage -> Affection UserData () +handleClicks (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft 1 pos@(V2 px py)) = do + rels@(V2 rx ry) <- liftIO $ fmap ((/ 2) . (+ 1)) <$> (relativizeMouseCoords pos) + when (arrowUp rels) adjustUpDown + where + adjustUpDown = liftIO $ logIO A.Debug "TODO: adjustUpDown" + arrowUp (V2 rx ry) = + rx > 310 / 1280 && rx < 410 / 1280 && ry > 190 / 720 && ry < 290 / 720 +handleClicks _ = return () + +updateMenu :: Double -> Affection UserData () +updateMenu dt = do + ud <- getAffection + putAffection ud + { stateData = MenuData + (velocity $ stateData ud) + (rotation $ stateData ud) + (max 0 ((activate $ stateData ud) - dt)) + } + +drawMenu :: Affection UserData () +drawMenu = do + ud <- getAffection + liftIO $ do + let ctx = nano ud + controller = joystick ud + save ctx + beginPath ctx + paint <- imagePattern ctx 600 620 80 80 0 (assetIcons ud M.! + if isNothing controller + then IconContrBlue + else IconContrGreen + ) 1 + rect ctx 600 620 80 80 + fillPaint ctx paint + fill ctx + when (isJust controller) $ do + let V2 vx vy = velocity $ stateData ud + beginPath ctx + roundedRect ctx 140 110 1000 500 25 + strokeWidth ctx 5 + fillColor ctx (rgba 255 255 255 128) + strokeColor ctx (rgba 255 255 255 255) + stroke ctx + fill ctx + mapM_ (\deg -> do + let V2 px py = fmap realToFrac $ + V2 360 360 - V2 50 50 + fmap realToFrac rot + rot@(V2 rx ry) = fmap (fromIntegral . floor) $ + V2 0 120 `rotVec` deg :: V2 Int + save ctx + translate ctx (px + 50) (py + 50) + rotate ctx (dtor deg) + translate ctx (-50) (-50) + case deg of + 0 -> when (vx < 0) $ do + beginPath ctx + fillColor ctx (rgb 255 128 0) + roundedRect ctx 0 0 100 100 10 + closePath ctx + fill ctx + case state ud of + Menu (Adjust (UpDown _)) -> do + fillColor ctx (rgb 0 255 0) + roundedRect ctx 0 0 100 100 10 + closePath ctx + fill ctx + _ -> + return () + 90 -> when (vy > 0) $ do + beginPath ctx + fillColor ctx (rgb 255 128 0) + roundedRect ctx 0 0 100 100 10 + closePath ctx + fill ctx + case state ud of + Menu (Adjust (LeftRight _)) -> do + fillColor ctx (rgb 0 255 0) + roundedRect ctx 0 0 100 100 10 + closePath ctx + fill ctx + _ -> + return () + 180 -> when (vx > 0) $ do + beginPath ctx + fillColor ctx (rgb 255 128 0) + roundedRect ctx 0 0 100 100 10 + closePath ctx + fill ctx + case state ud of + Menu (Adjust (UpDown _)) -> do + fillColor ctx (rgb 0 255 0) + roundedRect ctx 0 0 100 100 10 + closePath ctx + fill ctx + _ -> + return () + 270 -> when (vy < 0) $ do + beginPath ctx + fillColor ctx (rgb 255 128 0) + roundedRect ctx 0 0 100 100 10 + closePath ctx + fill ctx + case state ud of + Menu (Adjust (LeftRight _)) -> do + fillColor ctx (rgb 0 255 0) + roundedRect ctx 0 0 100 100 10 + closePath ctx + fill ctx + _ -> + return () + beginPath ctx + paint <- imagePattern ctx 0 0 100 100 0 (assetIcons ud M.! IconArrow) 1 + rect ctx 0 0 100 100 + fillPaint ctx paint + closePath ctx + fill ctx + restore ctx + ) [0, 90, 180, 270] + beginPath ctx + when (activate (stateData ud) > 0) $ do + fillColor ctx (rgb 255 128 0) + roundedRect ctx 650 160 150 50 10 + fill ctx + roundedRect ctx 650 160 150 50 10 + strokeWidth ctx 2 + stroke ctx + fontSize ctx 25 + fontFace ctx "bedstead" + textAlign ctx (S.fromList [AlignCenter, AlignTop]) + fillColor ctx (rgba 255 255 255 255) + textBox ctx 650 175 150 "Activate" + closePath ctx + restore ctx diff --git a/src/StateMachine.hs b/src/StateMachine.hs index 08a71d8..aae0684 100644 --- a/src/StateMachine.hs +++ b/src/StateMachine.hs @@ -7,22 +7,22 @@ import Affection import Types import Load -import Menu +import Menu.Connect import MainGame.WorldMap import MainGame.MindMap instance StateMachine State UserData where smLoad Load = loadLoad - smLoad Menu = loadMenu + smLoad (Menu Connect) = loadMenu smLoad (Main _) = loadMap smUpdate Load = updateLoad - smUpdate Menu = updateMenu + smUpdate (Menu Connect) = updateMenu smUpdate (Main WorldMap) = updateMap smUpdate (Main MindMap) = updateMind smDraw Load = drawLoad - smDraw Menu = drawMenu + smDraw (Menu Connect) = drawMenu smDraw (Main WorldMap) = drawMap smDraw (Main MindMap) = drawMind diff --git a/src/Types/ImgId.hs b/src/Types/ImgId.hs index 32092b5..9c45ebf 100644 --- a/src/Types/ImgId.hs +++ b/src/Types/ImgId.hs @@ -3,6 +3,7 @@ module Types.ImgId where data IconId = IconContrBlue | IconContrGreen + | IconArrow deriving (Show, Eq, Ord, Enum) data ImgId diff --git a/src/Types/StateData.hs b/src/Types/StateData.hs index 8b59fa4..8769b87 100644 --- a/src/Types/StateData.hs +++ b/src/Types/StateData.hs @@ -3,12 +3,15 @@ module Types.StateData where import Data.Matrix import Data.Map -import NanoVG +import NanoVG hiding (V2) + +import Linear (V2) import Types.ReachPoint import Types.Map import Types.ImgId import Types.Animation +import Types.Direction data StateData = None @@ -23,4 +26,9 @@ data StateData , reachPoints :: [ReachPoint] , mmImgMat :: Matrix (Maybe ImgId) } + | MenuData + { velocity :: V2 Double + , rotation :: Direction + , activate :: Double + } deriving (Eq) diff --git a/src/Types/UserData.hs b/src/Types/UserData.hs index fbfecd2..06990d3 100644 --- a/src/Types/UserData.hs +++ b/src/Types/UserData.hs @@ -43,11 +43,13 @@ data UserData = UserData , stateProgress :: MVar (Float, T.Text) , threadContext :: Maybe SDL.GLContext , window :: Maybe SDL.Window + , joyCache :: [JoystickMessage] + , joyUUID :: UUID } data State = Load - | Menu + | Menu SubMenu | Main SubMain deriving (Eq) @@ -56,41 +58,28 @@ data SubMain | MindMap deriving (Eq) +data SubMenu + = Connect + | Adjust Action + deriving (Eq) + defaultTranslation :: M.Map GamepadAction Action defaultTranslation = M.fromList - [ (ButtonAction 0 SDL.JoyButtonPressed, Jump) - , (ButtonAction 1 SDL.JoyButtonPressed, Duck) - , (ButtonAction 2 SDL.JoyButtonPressed, Kick) - , (ButtonAction 3 SDL.JoyButtonPressed, Punch) - , (ButtonAction 4 SDL.JoyButtonPressed, Grab) - , (ButtonAction 5 SDL.JoyButtonPressed, Block) - , (AxisAction 0 AxisNegative, GoLeft) - , (AxisAction 0 AxisPositive, GoRight) - , (AxisAction 0 AxisNeutral, StopLR) - , (AxisAction 1 AxisNegative, GoUp) - , (AxisAction 1 AxisPositive, GoDown) - , (AxisAction 1 AxisNeutral, StopUD) + [ (ButtonAction 0 SDL.JoyButtonPressed, Activate) + , (AxisAction 0, UpDown 0) + , (AxisAction 1, LeftRight 0) ] data Action - = Jump - | Duck - | Kick - | Punch - | Grab - | Block - | GoLeft - | GoRight - | GoUp - | GoDown - | StopLR - | StopUD - deriving (Show, Eq, Ord, Enum) + = Activate + | UpDown Int + | LeftRight Int + deriving (Show, Eq) data GamepadAction - = ButtonAction Word SDL.JoyButtonState - | AxisAction Word AxisAlign - | HatAction Word SDL.JoyHatPosition + = ButtonAction Word8 SDL.JoyButtonState + | AxisAction Word8 + -- | HatAction Word SDL.JoyHatPosition deriving (Show, Eq, Ord) data AxisAlign @@ -109,13 +98,12 @@ data Subsystems = Subsystems data ActionMessage = ActionMessage { amAction :: Action - , amJoystick :: Word , amTime :: Double } deriving (Eq, Show) instance Message ActionMessage where - msgTime (ActionMessage _ _ t) = t + msgTime (ActionMessage _ t) = t newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection UserData())]) newtype SubMouse = SubMouse (TVar [(UUID, MouseMessage -> Affection UserData ())]) diff --git a/src/Util.hs b/src/Util.hs index fa39b11..ddd4e47 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -18,7 +18,7 @@ import qualified Graphics.Rendering.OpenGL as GL hiding (get) import System.Exit (exitFailure) -import Linear hiding (E(..)) +import Linear hiding (E(..), translation) import NanoVG hiding (V2(..)) import NanoVG.Internal.Image (ImageFlags(..)) @@ -273,3 +273,35 @@ direction vel'@(V2 vr _) = if sqrt (vel' `dot` vel') > 0 | otherwise = NE in Just d else Nothing + +rotVec :: (Num a, Floating a) => V2 a -> a -> V2 a +rotVec (V2 x y) deg = V2 nx ny + where + nx = x * cos (dtor deg) + y * sin (dtor deg) + ny = x * sin (dtor deg) - y * cos (dtor deg) + +dtor :: (Num a, Floating a) => a -> a +dtor = (pi / 180 *) + +cacheJoypad :: JoystickMessage -> Affection UserData () +cacheJoypad msg = do + ud <- getAffection + putAffection ud + { joyCache = msg : joyCache ud + } + +emitActionMessage :: JoystickMessage -> Affection UserData () +emitActionMessage (MsgJoystickAxis time _ axis val) = do + ud <- getAffection + let Subsystems _ _ _ _ t = subsystems ud + case (translation ud) Map.!? (AxisAction axis) of + Just (UpDown _) -> partEmit t (ActionMessage (UpDown (fromIntegral val)) time) + Just (LeftRight _) -> partEmit t (ActionMessage (LeftRight (fromIntegral val)) time) + _ -> return () +emitActionMessage (MsgJoystickButton time _ but SDL.JoyButtonPressed) = do + ud <- getAffection + let Subsystems _ _ _ _ t = subsystems ud + case (translation ud) Map.!? (ButtonAction but SDL.JoyButtonPressed) of + Just Activate -> partEmit t (ActionMessage Activate time) + _ -> return () +emitActionMessage _ = return () diff --git a/tracer-game.cabal b/tracer-game.cabal index f4b38a8..4d7dc6f 100644 --- a/tracer-game.cabal +++ b/tracer-game.cabal @@ -40,7 +40,7 @@ executable tracer-game , Interior , Init , Load - , Menu + , Menu.Connect , MainGame.WorldMap , MainGame.MindMap , Navigation