moduleGraphics.Gloss.Data.ViewState(Command(..),CommandConfig,defaultCommandConfig,ViewState(..),ViewPort(..),viewStateInit,viewStateInitWithConfig,updateViewStateWithEvent,updateViewStateWithEventMaybe,applyViewPortToPicture,invertViewPort)whereimportGraphics.Gloss.Data.VectorimportGraphics.Gloss.Data.ViewPortimportGraphics.Gloss.Geometry.AngleimportGraphics.Gloss.Internals.Interface.BackendimportGraphics.Gloss.Internals.Interface.EventimportqualifiedData.MapasMapimportData.Map(Map)importData.MaybeimportControl.Monad(mplus)-- | The commands suported by the view controller.dataCommand=CRestore|CTranslate|CRotate-- bump zoom|CBumpZoomOut|CBumpZoomIn-- bump translate|CBumpLeft|CBumpRight|CBumpUp|CBumpDown-- bump rotate|CBumpClockwise|CBumpCClockwisederiving(Show,Eq,Ord)typeCommandConfig=[(Command,[(Key,MaybeModifiers)])]-- | The default commands. Left click pans, wheel zooms, right click-- rotates, "r" key resets.defaultCommandConfig::CommandConfigdefaultCommandConfig=[(CRestore,[(Char'r',Nothing)]),(CTranslate,[(MouseButtonLeftButton,Just(Modifiers{shift=Up,ctrl=Up,alt=Up}))]),(CRotate,[(MouseButtonRightButton,Nothing),(MouseButtonLeftButton,Just(Modifiers{shift=Up,ctrl=Down,alt=Up}))])-- bump zoom,(CBumpZoomOut,[(MouseButtonWheelDown,Nothing),(SpecialKeyKeyPageDown,Nothing)]),(CBumpZoomIn,[(MouseButtonWheelUp,Nothing),(SpecialKeyKeyPageUp,Nothing)])-- bump translate,(CBumpLeft,[(SpecialKeyKeyLeft,Nothing)]),(CBumpRight,[(SpecialKeyKeyRight,Nothing)]),(CBumpUp,[(SpecialKeyKeyUp,Nothing)]),(CBumpDown,[(SpecialKeyKeyDown,Nothing)])-- bump rotate,(CBumpClockwise,[(SpecialKeyKeyHome,Nothing)]),(CBumpCClockwise,[(SpecialKeyKeyEnd,Nothing)])]-- | Check if the provided key combination is some gloss viewport command.isCommand::MapCommand[(Key,MaybeModifiers)]->Command->Key->Modifiers->BoolisCommandcommandsckeykeyMods|JustcsMatch<-Map.lookupccommands=or$map(isCommand2ckeykeyMods)csMatch|otherwise=False-- | Check if the provided key combination is some gloss viewport command.isCommand2::Command->Key->Modifiers->(Key,MaybeModifiers)->BoolisCommand2_keykeyModscMatch|(keyC,mModsC)<-cMatch,keyC==key,casemModsCofNothing->TrueJustmodsC->modsC==keyMods=True|otherwise=False-- ViewControl State ------------------------------------------------------------- | State for controlling the viewport.-- These are used by the viewport control component.dataViewState=ViewState{-- | The command list for the viewport controller.-- These can be safely overwridden at any time by deleting-- or adding entries to the list.-- Entries at the front of the list take precedence.viewStateCommands::!(MapCommand[(Key,MaybeModifiers)])-- | How much to scale the world by for each step of the mouse wheel.,viewStateScaleStep::!Float-- | How many degrees to rotate the world by for each pixel of x motion.,viewStateRotateFactor::!Float-- | During viewport translation,-- where the mouse was clicked on the window.,viewStateTranslateMark::!(Maybe(Float,Float))-- | During viewport rotation, -- where the mouse was clicked on the window,viewStateRotateMark::!(Maybe(Float,Float)),viewStateViewPort::ViewPort}-- | The initial view state.viewStateInit::ViewStateviewStateInit=viewStateInitWithConfigdefaultCommandConfig-- | Initial view state, with user defined config.viewStateInitWithConfig::CommandConfig->ViewStateviewStateInitWithConfigcommandConfig=ViewState{viewStateCommands=Map.fromListcommandConfig,viewStateScaleStep=0.85,viewStateRotateFactor=0.6,viewStateTranslateMark=Nothing,viewStateRotateMark=Nothing,viewStateViewPort=viewPortInit}-- | Apply an event to a `ViewState`.updateViewStateWithEvent::Event->ViewState->ViewStateupdateViewStateWithEventevviewState=fromMaybeviewState$updateViewStateWithEventMaybeevviewState-- | Like 'updateViewStateWithEvent', but returns 'Nothing' if no update-- was needed.updateViewStateWithEventMaybe::Event->ViewState->MaybeViewStateupdateViewStateWithEventMaybe(EventKeykeykeyStatekeyModspos)viewState|isCommandcommandsCRestorekeykeyMods,keyState==Down=Just$viewState{viewStateViewPort=viewPortInit}|isCommandcommandsCBumpZoomOutkeykeyMods,keyState==Down=Just$controlZoomInviewState|isCommandcommandsCBumpZoomInkeykeyMods,keyState==Down=Just$controlZoomOutviewState|isCommandcommandsCBumpLeftkeykeyMods,keyState==Down=Just$viewState{viewStateViewPort=motionBumpport(20,0)}|isCommandcommandsCBumpRightkeykeyMods,keyState==Down=Just$viewState{viewStateViewPort=motionBumpport(-20,0)}|isCommandcommandsCBumpUpkeykeyMods,keyState==Down=Just$viewState{viewStateViewPort=motionBumpport(0,-20)}|isCommandcommandsCBumpDownkeykeyMods,keyState==Down=Just$viewState{viewStateViewPort=motionBumpport(0,20)}|isCommandcommandsCBumpClockwisekeykeyMods,keyState==Down=Just$viewState{viewStateViewPort=port{viewPortRotate=viewPortRotateport+5}}|isCommandcommandsCBumpCClockwisekeykeyMods,keyState==Down=Just$viewState{viewStateViewPort=port{viewPortRotate=viewPortRotateport-5}}|isCommandcommandsCTranslatekeykeyMods,keyState==Down,notcurrentlyRotating=Just$viewState{viewStateTranslateMark=Justpos}-- We don't want to use 'isCommand' here because the user may have-- released the translation modifier key before the mouse button.-- and we still want to cancel the translation.|currentlyTranslating,keyState==Up=Just$viewState{viewStateTranslateMark=Nothing}|isCommandcommandsCRotatekeykeyMods,keyState==Down,notcurrentlyTranslating=Just$viewState{viewStateRotateMark=Justpos}-- We don't want to use 'isCommand' here because the user may have-- released the rotation modifier key before the mouse button, -- and we still want to cancel the rotation.|currentlyRotating,keyState==Up=Just$viewState{viewStateRotateMark=Nothing}|otherwise=Nothingwherecommands=viewStateCommandsviewStateport=viewStateViewPortviewStatecurrentlyTranslating=isJust$viewStateTranslateMarkviewStatecurrentlyRotating=isJust$viewStateRotateMarkviewState-- Note that only a translation or rotation applies, not both at the same time.updateViewStateWithEventMaybe(EventMotionpos)viewState=motionTranslate(viewStateTranslateMarkviewState)posviewState`mplus`motionRotate(viewStateRotateMarkviewState)posviewState-- | Zoom in a `ViewState` by the scale step.controlZoomIn::ViewState->ViewStatecontrolZoomInviewState@ViewState{viewStateViewPort=port,viewStateScaleStep=scaleStep}=viewState{viewStateViewPort=port{viewPortScale=viewPortScaleport*scaleStep}}-- | Zoom out a `ViewState` by the scale step.controlZoomOut::ViewState->ViewStatecontrolZoomOutviewState@ViewState{viewStateViewPort=port,viewStateScaleStep=scaleStep}=viewState{viewStateViewPort=port{viewPortScale=viewPortScaleport/scaleStep}}-- | Offset a viewport.motionBump::ViewPort->(Float,Float)->ViewPortmotionBumpport@ViewPort{viewPortTranslate=trans,viewPortScale=scale,viewPortRotate=r}(bumpX,bumpY)=port{viewPortTranslate=trans-o}whereoffset=(bumpX/scale,bumpY/scale)o=rotateV(degToRadr)offset-- | Apply a translation to the `ViewState`.motionTranslate::Maybe(Float,Float)->(Float,Float)->ViewState->MaybeViewStatemotionTranslateNothing__=NothingmotionTranslate(Just(markX,markY))(posX,posY)viewState=Just$viewState{viewStateViewPort=port{viewPortTranslate=trans-o},viewStateTranslateMark=Just(posX,posY)}whereport=viewStateViewPortviewStatetrans=viewPortTranslateportscale=viewPortScaleportr=viewPortRotateportdX=markX-posXdY=markY-posYoffset=(dX/scale,dY/scale)o=rotateV(degToRadr)offset-- | Apply a rotation to the `ViewState`.motionRotate::Maybe(Float,Float)->(Float,Float)->ViewState->MaybeViewStatemotionRotateNothing__=NothingmotionRotate(Just(markX,_markY))(posX,posY)viewState=Just$viewState{viewStateViewPort=port{viewPortRotate=rotate-rotateFactor*(posX-markX)},viewStateRotateMark=Just(posX,posY)}whereport=viewStateViewPortviewStaterotate=viewPortRotateportrotateFactor=viewStateRotateFactorviewState