├── .envrc ├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── Setup.hs ├── examples └── src │ ├── BCircularLoop.hs │ ├── DampedOscillator.hs │ ├── ElectricFluxPlot.hs │ ├── HarmonicOscillator.hs │ ├── LorentzForceSimulation.hs │ ├── NMR.hs │ ├── PlaneWave.hs │ ├── Projectile.hs │ ├── eFieldLine2D.hs │ ├── eFieldLine3D.hs │ └── sunEarthRK4.hs ├── flake.lock ├── flake.nix ├── fourmolu.yaml ├── learn-physics.cabal ├── package.yaml └── src └── Physics ├── Learn.hs └── Learn ├── AdaptiveQuadrature.hs ├── BeamStack.hs ├── BlochSphere.hs ├── CarrotVec.hs ├── Charge.hs ├── CommonVec.hs ├── CompositeQuadrature.hs ├── CoordinateFields.hs ├── CoordinateSystem.hs ├── Current.hs ├── Curve.hs ├── Ket.hs ├── Mechanics.hs ├── Position.hs ├── QuantumMat.hs ├── RootFinding.hs ├── RungeKutta.hs ├── Schrodinger1D.hs ├── SimpleVec.hs ├── StateSpace.hs ├── Surface.hs ├── Visual ├── GlossTools.hs ├── PlotTools.hs └── VisTools.hs └── Volume.hs /.envrc: -------------------------------------------------------------------------------- 1 | if ! has nix_direnv_version || ! nix_direnv_version 2.2.0; then 2 | source_url "https://raw.githubusercontent.com/nix-community/nix-direnv/2.2.0/direnvrc" "sha256-5EwyKnkJNQeXrRkYbwwRBcXbibosCJqyIUuz9Xq+LRc=" 3 | fi 4 | 5 | nix_direnv_watch_file devenv.nix 6 | nix_direnv_watch_file devenv.lock 7 | nix_direnv_watch_file devenv.yaml 8 | nix_direnv_watch_file package.yaml 9 | use flake . --impure 10 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | communications/ 2 | dependencies/ 3 | dist/ 4 | dist-newstyle/ 5 | examples/cabal-dev/ 6 | RungeKutta/ 7 | SourceGraph/ 8 | stack20190510/ 9 | stack20190513/ 10 | _darcs/ 11 | .stack-work/ 12 | .devenv/ 13 | cabal.project-20200110 14 | cabal.project.local 15 | cabal.project.local~* 16 | Exercises.hs 17 | examples/src/Testing.hs 18 | src/PlaneWave.hs 19 | src/Tests.hs 20 | manifest20160412.txt 21 | *.o 22 | *.hi 23 | *~ 24 | *.tar.gz 25 | *-orig 26 | *.org 27 | *.log 28 | *.png 29 | *-conflict 30 | stack.yaml* 31 | .ghc.env* 32 | Learn 33 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # NB: don't set `language: haskell` here 2 | language: c 3 | 4 | # See also https://github.com/hvr/multi-ghc-travis for more information 5 | 6 | # The following lines enable several GHC versions and/or HP versions 7 | # to be tested; often it's enough to test only against the last 8 | # release of a major GHC version. Setting HPVER implictly sets 9 | # GHCVER. Omit lines with versions you don't need/want testing for. 10 | env: 11 | - CABALVER=3.8 GHCVER=9.4.4 12 | - CABALVER=3.6 GHCVER=9.2.5 13 | - CABALVER=3.6 GHCVER=9.0.2 14 | - CABALVER=3.6 GHCVER=8.10.7 15 | - CABALVER=3.6 GHCVER=8.8.4 16 | - CABALVER=2.4 GHCVER=8.8.1 17 | - CABALVER=2.4 GHCVER=8.6.5 18 | - CABALVER=2.2 GHCVER=8.4.4 19 | - CABALVER=2.0 GHCVER=8.2.2 20 | - CABALVER=1.24 GHCVER=8.0.2 21 | 22 | # Note: the distinction between `before_install` and `install` is not 23 | # important. 24 | before_install: 25 | - case "$HPVER" in 26 | "") ;; 27 | 28 | "2014.2.0.0") 29 | export CABALVER=1.18 ; 30 | export GHCVER=7.8.3 ; 31 | echo "constraints:async==2.0.1.5,attoparsec==0.10.4.0,case-insensitive==1.1.0.3,fgl==5.5.0.1,GLUT==2.5.1.1,GLURaw==1.4.0.1,haskell-src==1.0.1.6,hashable==1.2.2.0,html==1.0.1.2,HTTP==4000.2.10,HUnit==1.2.5.2,mtl==2.1.3.1,network==2.4.2.3,OpenGL==2.9.2.0,OpenGLRaw==1.5.0.0,parallel==3.2.0.4,parsec==3.1.5,primitive==0.5.2.1,QuickCheck==2.6,random==1.0.1.1,regex-base==0.93.2,regex-compat==0.95.1,regex-posix==0.95.2,split==0.2.2,stm==2.4.2,syb==0.4.1,text==1.1.0.0,transformers==0.3.0.0,unordered-containers==0.2.4.0,vector==0.10.9.1,xhtml==3000.2.1,zlib==0.5.4.1" > cabal.config ;; 32 | 33 | "2013.2.0.0") 34 | export CABALVER=1.16 ; 35 | export GHCVER=7.6.3 ; 36 | echo "constraints:async==2.0.1.4,attoparsec==0.10.4.0,case-insensitive==1.0.0.1,cgi==3001.1.7.5,fgl==5.4.2.4,GLUT==2.4.0.0,GLURaw==1.3.0.0,haskell-src==1.0.1.5,hashable==1.1.2.5,html==1.0.1.2,HTTP==4000.2.8,HUnit==1.2.5.2,mtl==2.1.2,network==2.4.1.2,OpenGL==2.8.0.0,OpenGLRaw==1.3.0.0,parallel==3.2.0.3,parsec==3.1.3,QuickCheck==2.6,random==1.0.1.1,regex-base==0.93.2,regex-compat==0.95.1,regex-posix==0.95.2,split==0.2.2,stm==2.4.2,syb==0.4.0,text==0.11.3.1,transformers==0.3.0.0,unordered-containers==0.2.3.0,vector==0.10.0.1,xhtml==3000.2.1,zlib==0.5.4.1" > cabal.config ;; 37 | 38 | "2012.4.0.0") 39 | export CABALVER=1.16 ; 40 | export GHCVER=7.6.2 ; 41 | echo "constraints:async==2.0.1.3,cgi==3001.1.7.4,fgl==5.4.2.4,GLUT==2.1.2.1,haskell-src==1.0.1.5,html==1.0.1.2,HTTP==4000.2.5,HUnit==1.2.5.1,mtl==2.1.2,network==2.3.1.0,OpenGL==2.2.3.1,parallel==3.2.0.3,parsec==3.1.3,QuickCheck==2.5.1.1,random==1.0.1.1,regex-base==0.93.2,regex-compat==0.95.1,regex-posix==0.95.2,split==0.2.1.1,stm==2.4,syb==0.3.7,text==0.11.2.3,transformers==0.3.0.0,vector==0.10.0.1,xhtml==3000.2.1,zlib==0.5.4.0" > cabal.config ;; 42 | 43 | "2012.2.0.0") 44 | export CABALVER=1.16 ; 45 | export GHCVER=7.4.1 ; 46 | echo "constraints:cgi==3001.1.7.4,fgl==5.4.2.4,GLUT==2.1.2.1,haskell-src==1.0.1.5,html==1.0.1.2,HTTP==4000.2.3,HUnit==1.2.4.2,mtl==2.1.1,network==2.3.0.13,OpenGL==2.2.3.1,parallel==3.2.0.2,parsec==3.1.2,QuickCheck==2.4.2,random==1.0.1.1,regex-base==0.93.2,regex-compat==0.95.1,regex-posix==0.95.1,stm==2.3,syb==0.3.6.1,text==0.11.2.0,transformers==0.3.0.0,xhtml==3000.2.1,zlib==0.5.3.3" > cabal.config ;; 47 | 48 | "2011.4.0.0") 49 | export CABALVER=1.16 ; 50 | export GHCVER=7.0.4 ; 51 | echo "constraints:cgi==3001.1.7.4,fgl==5.4.2.4,GLUT==2.1.2.1,haskell-src==1.0.1.4,html==1.0.1.2,HUnit==1.2.4.2,network==2.3.0.5,OpenGL==2.2.3.0,parallel==3.1.0.1,parsec==3.1.1,QuickCheck==2.4.1.1,regex-base==0.93.2,regex-compat==0.95.1,regex-posix==0.95.1,stm==2.2.0.1,syb==0.3.3,xhtml==3000.2.0.4,zlib==0.5.3.1,HTTP==4000.1.2,deepseq==1.1.0.2" > cabal.config ;; 52 | 53 | *) 54 | export GHCVER=unknown ; 55 | echo "unknown/invalid Haskell Platform requested" ; 56 | exit 1 ;; 57 | 58 | esac 59 | 60 | - travis_retry sudo add-apt-repository -y ppa:hvr/ghc 61 | - travis_retry sudo apt-get update 62 | - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER 63 | - travis_retry sudo apt-get install freeglut3-dev 64 | - travis_retry sudo apt-get install libblas-dev liblapack-dev 65 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 66 | 67 | install: 68 | - cabal --version 69 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 70 | - travis_retry cabal update 71 | - cabal install --only-dependencies --enable-tests --enable-benchmarks 72 | 73 | # Here starts the actual work to be performed for the package under 74 | # test; any command which exits with a non-zero exit code causes the 75 | # build to fail. 76 | script: 77 | - if [ -f configure.ac ]; then autoreconf -i; fi 78 | # -v2 provides useful information for debugging 79 | - cabal configure --enable-tests --enable-benchmarks -v2 80 | 81 | # this builds all libraries and executables 82 | # (including tests/benchmarks) 83 | - cabal build 84 | 85 | - cabal test 86 | - cabal check 87 | 88 | # tests that a source-distribution can be generated 89 | - cabal sdist 90 | 91 | # check that the generated source-distribution can be built & installed 92 | - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && 93 | (cd dist && cabal install --force-reinstalls "$SRC_TGZ") 94 | 95 | # EOF 96 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2011-2020 Scott N. Walck . 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above 11 | copyright notice, this list of conditions and the following 12 | disclaimer in the documentation and/or other materials provided 13 | with the distribution. 14 | 15 | * Neither the name of Scott N. Walck nor the names of other 16 | contributors may be used to endorse or promote products derived 17 | from this software without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # learn-physics 2 | 3 | [![Build Status](https://travis-ci.org/walck/learn-physics.svg?branch=master)](https://travis-ci.org/walck/learn-physics) 4 | 5 | A library of functions for vector calculus, calculation of electric 6 | field, electric flux, magnetic field, and other quantities in 7 | mechanics and electromagnetic theory. 8 | 9 | learn-physics is copyright © 2011-2020 Scott N. Walck, and released to the public under the terms of the BSD3 License 10 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /examples/src/BCircularLoop.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | module Main where 4 | 5 | import Physics.Learn 6 | import Vis 7 | 8 | loopCurve :: Curve 9 | loopCurve = Curve (\phi -> cyl 1 phi 0) 0 (2 * pi) 10 | 11 | loop :: CurrentDistribution 12 | loop = LineCurrent 20 loopCurve 13 | 14 | samplePoints :: [Position] 15 | samplePoints = 16 | [ cyl s phi z 17 | | s <- [0.25, 0.75 .. 1.75] 18 | , phi <- [pi / 6, pi / 2 .. 2 * pi] 19 | , z <- [-1.5, -1 .. 1.5] 20 | ] 21 | 22 | arrows :: VisObject Double 23 | arrows = displayVectorField blue 5e-5 samplePoints (bField loop) 24 | 25 | drawFun :: VisObject Double 26 | drawFun = VisObjects [curveObject red loopCurve, arrows] 27 | 28 | myOptions :: Options 29 | myOptions = defaultOpts {optWindowName = "Magnetic Field from a Current Loop"} 30 | 31 | main :: IO () 32 | main = display myOptions drawFun 33 | -------------------------------------------------------------------------------- /examples/src/DampedOscillator.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | -- | Damped harmonic oscillator 4 | module Main where 5 | 6 | import Graphics.Gnuplot.Simple 7 | import Physics.Learn.RungeKutta 8 | ( integrateSystem 9 | ) 10 | 11 | dampedOscillator 12 | :: Double 13 | -> Double 14 | -> Double 15 | -> (Double, Double, Double) 16 | -> (Double, Double, Double) 17 | dampedOscillator r l c (_t, vc, il) = 18 | (1, -vc / r / c - il / c, vc / l) 19 | 20 | theStates :: [(Double, Double, Double)] 21 | theStates = integrateSystem (dampedOscillator 10000 200 0.001) 0.01 (0, 1, 0) 22 | 23 | plot2 :: IO () 24 | plot2 = 25 | plotList 26 | [ Title "Damped Harmonic Oscillator" 27 | , XLabel "Time (s)" 28 | , YLabel "Voltage (V)" 29 | , Key Nothing 30 | ] 31 | (map (\(t, x, _) -> (t, x)) $ take 1000 theStates) 32 | 33 | main :: IO () 34 | main = main2 35 | 36 | main2 :: IO () 37 | main2 = 38 | plotPath 39 | [ Title "Damped Harmonic Oscillator" 40 | , XLabel "Time (s)" 41 | , YLabel "Voltage (V)" 42 | , Key Nothing 43 | , PNG "learn-physics-DHO.png" 44 | ] 45 | (map (\(t, x, _) -> (t, x)) $ take 1000 theStates) 46 | >> putStrLn "output sent to file learn-physics-DHO.png" 47 | -------------------------------------------------------------------------------- /examples/src/ElectricFluxPlot.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | -- | Electric flux plot. Load this file into GHCi and ask for plot1. 4 | module Main where 5 | 6 | import Graphics.Gnuplot.Simple 7 | import Physics.Learn.Charge 8 | import Physics.Learn.Position 9 | import Physics.Learn.Surface 10 | 11 | -- | A plot of electric flux produced by a 1-nC point charge at (x,y,z) = (x,0,0) 12 | -- through a sphere of radius 2 m centered at the origin 13 | -- as a function of x. 14 | plot1 :: IO () 15 | plot1 = 16 | plotFunc 17 | [ Title "Electric flux produced by a 1-nC point charge through a sphere with radius 2m" 18 | , YLabel "Electric flux (V m)" 19 | , XLabel "Displacement of point charge from center of sphere (m)" 20 | , Key Nothing 21 | ] 22 | [-3.05, -2.95 .. 3] 23 | (\x -> electricFlux (sphere 2 (cart 0 0 0)) (PointCharge 1e-9 (cart x 0 0))) 24 | 25 | -- | Electric flux plot 26 | main :: IO () 27 | main = plot1 28 | -------------------------------------------------------------------------------- /examples/src/HarmonicOscillator.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | module Main where 4 | 5 | import Graphics.Gloss 6 | ( Display (..) 7 | , black 8 | , display 9 | ) 10 | import Physics.Learn.Schrodinger1D 11 | ( gaussian 12 | , picture 13 | , stateVectorFromWavefunction 14 | , xRange 15 | ) 16 | 17 | main1 :: IO () 18 | main1 = 19 | display 20 | (InWindow "Probability Wave" (1920, 1080) (0, 0)) 21 | black 22 | ( picture 23 | (0, 1) 24 | (xRange (-10) 10 501) 25 | ( stateVectorFromWavefunction 26 | (-10) 27 | 10 28 | 501 29 | (gaussian 1 1) 30 | ) 31 | ) 32 | 33 | main :: IO () 34 | main = main1 35 | -------------------------------------------------------------------------------- /examples/src/LorentzForceSimulation.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Physics.Learn 4 | import SpatialMath 5 | ( Euler (..) 6 | ) 7 | import Vis 8 | 9 | drawFunction :: SimpleState -> VisObject Double 10 | drawFunction (_t, r, _v) = 11 | RotEulerDeg (Euler 270 0 0) $ 12 | RotEulerDeg (Euler 0 180 0) $ 13 | VisObjects 14 | [ Axes (0.5, 15) 15 | , Trans (v3FromPos r) (Sphere 0.1 Solid red) 16 | ] 17 | 18 | statePropagationFunction :: Float -> SimpleState -> SimpleState 19 | statePropagationFunction t' (t, r, v) = rungeKutta4 newton2 (realToFrac t' - t) (t, r, v) 20 | 21 | -- Newton's Second Law 22 | newton2 :: SimpleState -> Diff SimpleState 23 | newton2 (t, r, v) = (1, v, force (t, r, v) ^/ m) 24 | 25 | -- Lorentz Force Law 26 | force :: SimpleState -> Vec 27 | force (_t, r, v) = q *^ (electricField r ^+^ v >< magneticField r) 28 | 29 | myOptions :: Options 30 | myOptions = defaultOpts {optWindowName = "Particle Experiencing Electromagnetic Force"} 31 | 32 | main :: IO () 33 | main = 34 | simulate 35 | myOptions 36 | 0.01 37 | (0, initialPosition, initialVelocity) 38 | drawFunction 39 | statePropagationFunction 40 | 41 | -- particle mass 42 | m :: Double 43 | m = 1 44 | 45 | -- particle charge 46 | q :: Double 47 | q = 1 48 | 49 | -- Electric Field 50 | electricField :: VectorField 51 | electricField r = vec 0 2 0 52 | where 53 | (x, y, z) = cartesianCoordinates r 54 | 55 | -- Magnetic Field 56 | magneticField :: VectorField 57 | magneticField r = vec 0 0 4 58 | where 59 | (x, y, z) = cartesianCoordinates r 60 | 61 | -- Initial displacement 62 | initialPosition :: Position 63 | initialPosition = cart 0 0 0 64 | 65 | -- Initial velocity 66 | initialVelocity :: Vec 67 | initialVelocity = vec 0 0 0 68 | -------------------------------------------------------------------------------- /examples/src/NMR.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | -- \^ Nuclear Magnetic Resonance on the Bloch Sphere 4 | 5 | module Main where 6 | 7 | import Physics.Learn.BlochSphere 8 | ( evolutionBlochSphere 9 | , hamRabi 10 | ) 11 | import Physics.Learn.QuantumMat 12 | ( zm 13 | ) 14 | 15 | main :: IO () 16 | main = evolutionBlochSphere zm (hamRabi 10 1 10) 17 | -------------------------------------------------------------------------------- /examples/src/PlaneWave.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | module Main where 4 | 5 | import Physics.Learn 6 | ( Position 7 | , VectorField 8 | , cart 9 | , cartesianCoordinates 10 | , displayVectorField 11 | ) 12 | import Physics.Learn.CarrotVec 13 | ( vec 14 | ) 15 | import Vis 16 | ( Options (..) 17 | , VisObject (..) 18 | , animate 19 | , blue 20 | , defaultOpts 21 | , red 22 | ) 23 | 24 | samplePoints :: [Position] 25 | samplePoints = [cart x y z | x <- [-2, 0, 2], y <- [-2, 0, 2], z <- [-4, -3.6 .. 4]] 26 | 27 | drawFun :: Float -> VisObject Double 28 | drawFun time = 29 | VisObjects 30 | [ displayVectorField blue 1 samplePoints (eField t) 31 | , displayVectorField red 1 samplePoints (bField t) 32 | ] 33 | where 34 | t = realToFrac time 35 | 36 | eField :: Double -> VectorField 37 | eField t r = vec (cos (z - t)) 0 0 38 | where 39 | (_, _, z) = cartesianCoordinates r 40 | 41 | bField :: Double -> VectorField 42 | bField t r = vec 0 (cos (z - t)) 0 43 | where 44 | (_, _, z) = cartesianCoordinates r 45 | 46 | myOptions :: Options 47 | myOptions = defaultOpts {optWindowName = "Plane Wave"} 48 | 49 | main :: IO () 50 | main = animate myOptions drawFun 51 | -------------------------------------------------------------------------------- /examples/src/Projectile.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | module Main where 4 | 5 | import Graphics.Gnuplot.Simple 6 | import Physics.Learn 7 | 8 | -- type StateTuple = (Double,Vec,Vec) 9 | -- type AccelerationFunction = StateTuple -> Vec 10 | 11 | -- eulerCromerSolution :: Double -> AccelerationFunction 12 | -- -> StateTuple -> StateTuple 13 | -- eulerCromerSolution 14 | 15 | -- vertical direction is y direction 16 | earthSurfaceGravity :: OneParticleAccelerationFunction 17 | earthSurfaceGravity _state = vec 0 (-g) 0 18 | 19 | g :: Double 20 | g = 9.81 21 | 22 | projectileTuples 23 | :: Double 24 | -> Double 25 | -> OneParticleAccelerationFunction 26 | -> [OneParticleSystemState] 27 | projectileTuples v0 theta af = 28 | oneParticleRungeKuttaSolution 29 | af 30 | 0.01 31 | (0, St (cart 0 0 0) (vec vx0 vy0 0)) 32 | where 33 | vx0 = v0 * cos theta 34 | vy0 = v0 * sin theta 35 | 36 | yCoord :: Position -> Double 37 | yCoord r = y 38 | where 39 | (_, y, _) = cartesianCoordinates r 40 | 41 | inAir :: [OneParticleSystemState] -> [OneParticleSystemState] 42 | inAir = takeWhile (\(_, St r _) -> yCoord r >= 0) 43 | 44 | initialProjState :: Double -> Double -> OneParticleSystemState 45 | initialProjState v0 theta = 46 | (0, St (cart 0 0 0) (vec vx0 vy0 0)) 47 | where 48 | vx0 = v0 * cos theta 49 | vy0 = v0 * sin theta 50 | 51 | -- air resistance quadratic in the speed 52 | surfaceGravityAirResistance 53 | :: Double 54 | -> Double 55 | -> OneParticleAccelerationFunction 56 | surfaceGravityAirResistance m b (_t, St _r v) = 57 | netForce ^/ m 58 | where 59 | netForce = gravity ^+^ airResistance 60 | gravity = vec 0 (-m * g) 0 61 | airResistance = ((-b) * magnitude v) *^ v 62 | 63 | trajectory :: [OneParticleSystemState] -> [(Double, Double)] 64 | trajectory sts = [(x, y) | (_, St r _) <- sts, let (x, y, _) = cartesianCoordinates r] 65 | 66 | traj :: Double -> [(Double, Double)] 67 | traj b = 68 | trajectory $ 69 | inAir $ 70 | oneParticleRungeKuttaSolution 71 | (surfaceGravityAirResistance 2 b) 72 | 0.01 73 | (initialProjState 30 (pi / 6)) 74 | 75 | main :: IO () 76 | main = 77 | plotPathsStyle 78 | [ Title "Trajectories of 2-kg object, initial speed 30 m/s, angle 30 degrees" 79 | , XLabel "Range (m)" 80 | , YLabel "Height (m)" 81 | , PNG "learn-physics-Projectile.png" 82 | ] 83 | [ (defaultStyle {lineSpec = CustomStyle [LineTitle "No air resistance"]}, traj 0) 84 | , (defaultStyle {lineSpec = CustomStyle [LineTitle "Drag 0.01 kg/m"]}, traj 0.01) 85 | , (defaultStyle {lineSpec = CustomStyle [LineTitle "Drag 0.02 kg/m"]}, traj 0.02) 86 | ] 87 | >> putStrLn "output sent to file learn-physics-Projectile.png" 88 | -------------------------------------------------------------------------------- /examples/src/eFieldLine2D.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | module Main where 4 | 5 | import Graphics.Gloss 6 | import Physics.Learn.CarrotVec 7 | import Physics.Learn.Charge 8 | import Physics.Learn.Curve 9 | import Physics.Learn.Position 10 | import Physics.Learn.Visual.GlossTools 11 | 12 | pixelsPerMeter :: Float 13 | pixelsPerMeter = 40 14 | 15 | pixelsPerVPM :: Float 16 | pixelsPerVPM = 5.6 17 | 18 | scalePoint :: Float -> Point -> Point 19 | scalePoint m (x, y) = (m * x, m * y) 20 | 21 | twoD :: Vec -> Point 22 | twoD r = (realToFrac $ xComp r, realToFrac $ yComp r) 23 | 24 | twoDp :: Position -> Point 25 | twoDp r = (realToFrac x, realToFrac y) 26 | where 27 | (x, y, _) = cartesianCoordinates r 28 | 29 | samplePoints :: [Position] 30 | samplePoints = [cart x y 0 | x <- [-8, -6 .. 8], y <- [-6, -4 .. 6], abs y > 0.5 || abs x > 4.5] 31 | 32 | curve1 :: Curve 33 | curve1 = Curve (\t -> cart t 0 0) (-4) 4 34 | 35 | eFields :: [(Position, Vec)] 36 | eFields = [(r, eFieldFromLineCharge (const 1e-9) curve1 r) | r <- samplePoints] 37 | 38 | arrows :: [Picture] 39 | arrows = 40 | [ thickArrow 41 | 5 42 | (scalePoint pixelsPerMeter $ twoDp r) 43 | (scalePoint pixelsPerVPM $ twoD e) 44 | | (r, e) <- eFields 45 | ] 46 | 47 | main :: IO () 48 | main = 49 | display (InWindow "Electric Field from a Line Charge" (680, 520) (10, 10)) white $ 50 | Pictures 51 | [ (Color blue (Pictures arrows)) 52 | , Color orange $ Line [(-4 * pixelsPerMeter, 0), (4 * pixelsPerMeter, 0)] 53 | ] 54 | -------------------------------------------------------------------------------- /examples/src/eFieldLine3D.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | module Main where 4 | 5 | import Physics.Learn.Charge 6 | ( ChargeDistribution (..) 7 | , eField 8 | ) 9 | import Physics.Learn.Curve 10 | ( Curve (..) 11 | ) 12 | import Physics.Learn.Position 13 | ( Position 14 | , cart 15 | ) 16 | import Physics.Learn.Visual.VisTools 17 | ( curveObject 18 | , displayVectorField 19 | ) 20 | import Vis 21 | ( Options (..) 22 | , VisObject (..) 23 | , blue 24 | , defaultOpts 25 | , display 26 | , red 27 | ) 28 | 29 | curve1 :: Curve 30 | curve1 = Curve (\t -> cart t 0 0) (-4) 4 31 | 32 | lineCharge :: ChargeDistribution 33 | lineCharge = LineCharge (const 1e-9) curve1 34 | 35 | samplePoints :: [Position] 36 | samplePoints = [cart x y z | x <- [-8, -6 .. 8], y <- [-4, -2 .. 4], z <- [-4, -2 .. 4], abs y + abs z > 0.5 || abs x > 4.5] 37 | 38 | arrows :: VisObject Double 39 | arrows = displayVectorField blue 10 samplePoints (eField lineCharge) 40 | 41 | drawFun :: VisObject Double 42 | drawFun = VisObjects [curveObject red curve1, arrows] 43 | 44 | myOptions :: Options 45 | myOptions = defaultOpts {optWindowName = "Electric Field from a Line Charge"} 46 | 47 | main :: IO () 48 | main = display myOptions drawFun 49 | -------------------------------------------------------------------------------- /examples/src/sunEarthRK4.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | -- Animation of Earth orbiting around a fixed Sun 4 | -- Using SI units 5 | 6 | module Main where 7 | 8 | import Graphics.Gloss 9 | import Graphics.Gloss.Data.ViewPort 10 | import Physics.Learn 11 | 12 | type Acceleration = Vec 13 | 14 | gGrav :: Double 15 | gGrav = 6.67e-11 16 | 17 | massSun :: Double 18 | massSun = 1.99e30 19 | 20 | -- This is enlarged so we can see it. 21 | radiusSun :: Double 22 | radiusSun = 0.1 * earthSunDistance 23 | 24 | -- This is enlarged so we can see it. 25 | radiusEarth :: Double 26 | radiusEarth = 0.05 * earthSunDistance 27 | 28 | earthSunDistance :: Double 29 | earthSunDistance = 1.496e11 30 | 31 | year :: Double 32 | year = 365.25 * 24 * 60 * 60 33 | 34 | -- Derived constants 35 | 36 | initialEarthSpeed :: Double 37 | initialEarthSpeed = 2 * pi * earthSunDistance / year 38 | 39 | initialState :: SimpleState 40 | initialState = 41 | ( 0 42 | , cart earthSunDistance 0 0 43 | , vec 0 initialEarthSpeed 0 44 | ) 45 | 46 | rS :: Position 47 | rS = cart 0 0 0 48 | 49 | earthGravity :: SimpleAccelerationFunction 50 | earthGravity (_, rE, _) = 51 | ((-gGrav) * massSun) *^ disp ^/ magnitude disp ** 3 52 | where 53 | disp = displacement rS rE 54 | 55 | diskPic :: Double -> Picture 56 | diskPic r = ThickCircle (radius / 2) radius 57 | where 58 | radius = realToFrac r 59 | 60 | -- A yellow disk will represent the Sun 61 | yellowDisk :: Picture 62 | yellowDisk = Color yellow (diskPic radiusSun) 63 | 64 | -- A blue disk will represent the Earth 65 | blueDisk :: Picture 66 | blueDisk = Color blue (diskPic radiusEarth) 67 | 68 | worldToPicture :: SimpleState -> Picture 69 | worldToPicture (_, rE, _) = 70 | scale scl scl $ 71 | pictures 72 | [ yellowDisk 73 | , translate xE yE blueDisk 74 | ] 75 | where 76 | xE = realToFrac x 77 | yE = realToFrac y 78 | scl = 200 / realToFrac (earthSunDistance) 79 | (x, y, _) = cartesianCoordinates rE 80 | 81 | timeScale :: Double 82 | timeScale = 0.25 * year 83 | 84 | simStep :: ViewPort -> Float -> SimpleState -> SimpleState 85 | simStep _ dt = simpleRungeKuttaStep earthGravity dtScaled 86 | where 87 | dtScaled = timeScale * realToFrac dt 88 | 89 | main :: IO () 90 | main = 91 | simulate 92 | (InWindow "Sun-Earth Animation" (1024, 768) (0, 0)) 93 | black 94 | 50 95 | initialState 96 | worldToPicture 97 | simStep 98 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs = { 3 | nixpkgs.url = "github:NixOS/nixpkgs?ref=haskell-updates"; 4 | devenv.url = "github:cachix/devenv"; 5 | nix-filter.url = "github:numtide/nix-filter"; 6 | spatial-math.url = "github:smunix/spatial-math?ref=fix.no-TypeCompose"; 7 | not-gloss.url = "github:smunix/not-gloss?ref=fix.spatial-math-0502"; 8 | }; 9 | 10 | outputs = { self, nixpkgs, devenv, nix-filter, ... }@inputs: 11 | with nix-filter.lib; 12 | let 13 | systems = [ 14 | "x86_64-linux" 15 | # "i686-linux" 16 | "x86_64-darwin" 17 | # "aarch64-linux" 18 | # "aarch64-darwin" 19 | ]; 20 | config = { allowBroken = true; }; 21 | overlays.default = final: previous: { 22 | haskellPackages = with final.haskell.lib; 23 | previous.haskellPackages.extend (hfinal: hprevious: 24 | with hfinal; { 25 | learn-physics = disableOptimization (dontHaddock 26 | (callCabal2nix "learn-physics" (filter { 27 | root = self; 28 | exclude = [ (matchExt "cabal") ]; 29 | }) { })); 30 | }); 31 | }; 32 | forAllSystems = f: 33 | builtins.listToAttrs (map (name: { 34 | inherit name; 35 | value = f name; 36 | }) systems); 37 | in { 38 | inherit overlays; 39 | packages = forAllSystems (system: 40 | let 41 | pkgs = import nixpkgs { 42 | inherit config system; 43 | overlays = [ 44 | inputs.spatial-math.overlays.default 45 | inputs.not-gloss.overlays.default 46 | overlays.default 47 | ]; 48 | }; 49 | in { default = pkgs.haskellPackages.learn-physics; }); 50 | devShells = forAllSystems (system: 51 | let 52 | pkgs = import nixpkgs { 53 | inherit config system; 54 | overlays = with inputs; [ 55 | inputs.spatial-math.overlays.default 56 | inputs.not-gloss.overlays.default 57 | overlays.default 58 | ]; 59 | }; 60 | in { 61 | default = devenv.lib.mkShell { 62 | inherit inputs pkgs; 63 | modules = with pkgs.haskellPackages; 64 | with pkgs; [{ 65 | env = { name = "learn-physics"; }; 66 | enterShell = '' 67 | setUp 68 | ''; 69 | packages = [ 70 | gnuplot 71 | (ghcWithPackages 72 | (p: with p; [ learn-physics haskell-language-server ])) 73 | ]; 74 | pre-commit.hooks = { 75 | fourmolu.enable = true; 76 | nixfmt.enable = true; 77 | }; 78 | scripts = { 79 | run-ghcid.exec = '' 80 | ${ghcid}/bin/ghcid -W -a -c "cabal repl lib:learn-physics" 81 | ''; 82 | setUp.exec = '' 83 | if [ -f package.yaml ] 84 | then 85 | ${hpack}/bin/hpack -f package.yaml 86 | fi 87 | if [ -f learn-physics.cabal ] 88 | then 89 | ${implicit-hie}/bin/gen-hie --cabal &> hie.yaml 90 | fi 91 | ''; 92 | }; 93 | }]; 94 | }; 95 | }); 96 | }; 97 | } 98 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | # Options should imitate Ormolu's style 2 | indentation: 2 3 | function-arrows: leading 4 | comma-style: leading 5 | import-export-style: leading 6 | indent-wheres: true 7 | record-brace-space: true 8 | newlines-between-decls: 1 9 | haddock-style: single-line 10 | haddock-style-module: multi-line 11 | let-style: inline 12 | in-style: right-align 13 | unicode: never 14 | respectful: false 15 | fixities: [] 16 | -------------------------------------------------------------------------------- /learn-physics.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.35.1. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: learn-physics 8 | version: 0.6.5 9 | synopsis: Haskell code for learning physics 10 | description: A library of functions for vector calculus, calculation of electric field, electric flux, magnetic field, and other quantities in classical mechanics, electromagnetic theory, and quantum mechanics. 11 | category: Physics 12 | homepage: https://github.com/walck/learn-physics#readme 13 | bug-reports: https://github.com/walck/learn-physics/issues 14 | author: Scott N. Walck 15 | maintainer: Scott N. Walck 16 | license: BSD3 17 | license-file: LICENSE 18 | build-type: Simple 19 | 20 | source-repository head 21 | type: git 22 | location: https://github.com/walck/learn-physics 23 | 24 | library 25 | exposed-modules: 26 | Physics.Learn 27 | Physics.Learn.AdaptiveQuadrature 28 | Physics.Learn.BeamStack 29 | Physics.Learn.BlochSphere 30 | Physics.Learn.CarrotVec 31 | Physics.Learn.Charge 32 | Physics.Learn.CommonVec 33 | Physics.Learn.CompositeQuadrature 34 | Physics.Learn.CoordinateFields 35 | Physics.Learn.CoordinateSystem 36 | Physics.Learn.Current 37 | Physics.Learn.Curve 38 | Physics.Learn.Ket 39 | Physics.Learn.Mechanics 40 | Physics.Learn.Position 41 | Physics.Learn.QuantumMat 42 | Physics.Learn.RootFinding 43 | Physics.Learn.RungeKutta 44 | Physics.Learn.Schrodinger1D 45 | Physics.Learn.SimpleVec 46 | Physics.Learn.StateSpace 47 | Physics.Learn.Surface 48 | Physics.Learn.Visual.GlossTools 49 | Physics.Learn.Visual.PlotTools 50 | Physics.Learn.Visual.VisTools 51 | Physics.Learn.Volume 52 | other-modules: 53 | Paths_learn_physics 54 | hs-source-dirs: 55 | src 56 | build-depends: 57 | base 58 | , gloss 59 | , gnuplot 60 | , hmatrix 61 | , not-gloss 62 | , spatial-math 63 | , vector-space 64 | default-language: Haskell2010 65 | 66 | executable learn-physics-BCircularLoop 67 | main-is: examples/src/BCircularLoop.hs 68 | other-modules: 69 | Paths_learn_physics 70 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 71 | build-depends: 72 | base 73 | , learn-physics 74 | , not-gloss 75 | default-language: Haskell2010 76 | 77 | executable learn-physics-DampedOscillator 78 | main-is: examples/src/DampedOscillator.hs 79 | other-modules: 80 | Paths_learn_physics 81 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 82 | build-depends: 83 | base 84 | , gnuplot 85 | , learn-physics 86 | default-language: Haskell2010 87 | 88 | executable learn-physics-ElectricFluxPlot 89 | main-is: examples/src/ElectricFluxPlot.hs 90 | other-modules: 91 | Paths_learn_physics 92 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 93 | build-depends: 94 | base 95 | , gnuplot 96 | , learn-physics 97 | default-language: Haskell2010 98 | 99 | executable learn-physics-HarmonicOscillator 100 | main-is: examples/src/HarmonicOscillator.hs 101 | other-modules: 102 | Paths_learn_physics 103 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 104 | build-depends: 105 | base 106 | , gloss 107 | , learn-physics 108 | default-language: Haskell2010 109 | 110 | executable learn-physics-LorentzForceSimulation 111 | main-is: examples/src/LorentzForceSimulation.hs 112 | other-modules: 113 | Paths_learn_physics 114 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 115 | build-depends: 116 | base 117 | , learn-physics 118 | , not-gloss 119 | , spatial-math 120 | default-language: Haskell2010 121 | 122 | executable learn-physics-NMR 123 | main-is: examples/src/NMR.hs 124 | other-modules: 125 | Paths_learn_physics 126 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 127 | build-depends: 128 | base 129 | , learn-physics 130 | default-language: Haskell2010 131 | 132 | executable learn-physics-PlaneWave 133 | main-is: examples/src/PlaneWave.hs 134 | other-modules: 135 | Paths_learn_physics 136 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 137 | build-depends: 138 | base 139 | , learn-physics 140 | , not-gloss 141 | default-language: Haskell2010 142 | 143 | executable learn-physics-Projectile 144 | main-is: examples/src/Projectile.hs 145 | other-modules: 146 | Paths_learn_physics 147 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 148 | build-depends: 149 | base 150 | , gnuplot 151 | , learn-physics 152 | default-language: Haskell2010 153 | 154 | executable learn-physics-eFieldLine2D 155 | main-is: examples/src/eFieldLine2D.hs 156 | other-modules: 157 | Paths_learn_physics 158 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 159 | build-depends: 160 | base 161 | , gloss 162 | , learn-physics 163 | default-language: Haskell2010 164 | 165 | executable learn-physics-eFieldLine3D 166 | main-is: examples/src/eFieldLine3D.hs 167 | other-modules: 168 | Paths_learn_physics 169 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 170 | build-depends: 171 | base 172 | , learn-physics 173 | , not-gloss 174 | default-language: Haskell2010 175 | 176 | executable learn-physics-sunEarth 177 | main-is: examples/src/sunEarthRK4.hs 178 | other-modules: 179 | Paths_learn_physics 180 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 181 | build-depends: 182 | base 183 | , gloss 184 | , learn-physics 185 | default-language: Haskell2010 186 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: learn-physics 2 | version: 0.6.5 3 | synopsis: Haskell code for learning physics 4 | description: A library of functions for vector calculus, 5 | calculation of electric field, electric flux, 6 | magnetic field, and other quantities in classical mechanics, 7 | electromagnetic theory, and quantum mechanics. 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Scott N. Walck 11 | maintainer: Scott N. Walck 12 | category: Physics 13 | github: walck/learn-physics 14 | test-with: GHC==9.2.4 15 | 16 | library: 17 | source-dirs: src 18 | dependencies: 19 | - base 20 | - vector-space 21 | - hmatrix 22 | - gloss 23 | - gnuplot 24 | - not-gloss 25 | - spatial-math 26 | 27 | executables: 28 | learn-physics-PlaneWave: 29 | main: examples/src/PlaneWave.hs 30 | ghc-options: 31 | - -threaded 32 | - -rtsopts 33 | - -with-rtsopts=-N 34 | dependencies: 35 | - base 36 | - learn-physics 37 | - not-gloss 38 | 39 | learn-physics-eFieldLine3D: 40 | main: examples/src/eFieldLine3D.hs 41 | ghc-options: 42 | - -threaded 43 | - -rtsopts 44 | - -with-rtsopts=-N 45 | dependencies: 46 | - base 47 | - learn-physics 48 | - not-gloss 49 | 50 | learn-physics-LorentzForceSimulation: 51 | main: examples/src/LorentzForceSimulation.hs 52 | ghc-options: 53 | - -threaded 54 | - -rtsopts 55 | - -with-rtsopts=-N 56 | dependencies: 57 | - base 58 | - learn-physics 59 | - spatial-math 60 | - not-gloss 61 | 62 | learn-physics-BCircularLoop: 63 | main: examples/src/BCircularLoop.hs 64 | ghc-options: 65 | - -threaded 66 | - -rtsopts 67 | - -with-rtsopts=-N 68 | dependencies: 69 | - base 70 | - learn-physics 71 | - not-gloss 72 | 73 | learn-physics-sunEarth: 74 | main: examples/src/sunEarthRK4.hs 75 | ghc-options: 76 | - -threaded 77 | - -rtsopts 78 | - -with-rtsopts=-N 79 | dependencies: 80 | - base 81 | - learn-physics 82 | - gloss 83 | 84 | learn-physics-eFieldLine2D: 85 | main: examples/src/eFieldLine2D.hs 86 | ghc-options: 87 | - -threaded 88 | - -rtsopts 89 | - -with-rtsopts=-N 90 | dependencies: 91 | - base 92 | - learn-physics 93 | - gloss 94 | 95 | learn-physics-Projectile: 96 | main: examples/src/Projectile.hs 97 | ghc-options: 98 | - -threaded 99 | - -rtsopts 100 | - -with-rtsopts=-N 101 | dependencies: 102 | - base 103 | - learn-physics 104 | - gnuplot 105 | 106 | learn-physics-NMR: 107 | main: examples/src/NMR.hs 108 | ghc-options: 109 | - -threaded 110 | - -rtsopts 111 | - -with-rtsopts=-N 112 | dependencies: 113 | - base 114 | - learn-physics 115 | 116 | learn-physics-HarmonicOscillator: 117 | main: examples/src/HarmonicOscillator.hs 118 | ghc-options: 119 | - -threaded 120 | - -rtsopts 121 | - -with-rtsopts=-N 122 | dependencies: 123 | - base 124 | - learn-physics 125 | - gloss 126 | 127 | learn-physics-ElectricFluxPlot: 128 | main: examples/src/ElectricFluxPlot.hs 129 | ghc-options: 130 | - -threaded 131 | - -rtsopts 132 | - -with-rtsopts=-N 133 | dependencies: 134 | - base 135 | - learn-physics 136 | - gnuplot 137 | 138 | learn-physics-DampedOscillator: 139 | main: examples/src/DampedOscillator.hs 140 | ghc-options: 141 | - -threaded 142 | - -rtsopts 143 | - -with-rtsopts=-N 144 | dependencies: 145 | - base 146 | - learn-physics 147 | - gnuplot 148 | -------------------------------------------------------------------------------- /src/Physics/Learn.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | 4 | -- | 5 | --Module : Physics.Learn 6 | --Copyright : (c) Scott N. Walck 2014-2018 7 | --License : BSD3 (see LICENSE) 8 | --Maintainer : Scott N. Walck 9 | --Stability : experimental 10 | -- 11 | --Functions for learning physics. 12 | module Physics.Learn 13 | ( -- * Mechanics 14 | TheTime 15 | , TimeStep 16 | , Velocity 17 | 18 | -- ** Simple one-particle state 19 | , SimpleState 20 | , SimpleAccelerationFunction 21 | , simpleStateDeriv 22 | , simpleRungeKuttaStep 23 | 24 | -- ** One-particle state 25 | , St (..) 26 | , DSt (..) 27 | , OneParticleSystemState 28 | , OneParticleAccelerationFunction 29 | , oneParticleStateDeriv 30 | , oneParticleRungeKuttaStep 31 | , oneParticleRungeKuttaSolution 32 | 33 | -- ** Two-particle state 34 | , TwoParticleSystemState 35 | , TwoParticleAccelerationFunction 36 | , twoParticleStateDeriv 37 | , twoParticleRungeKuttaStep 38 | 39 | -- ** Many-particle state 40 | , ManyParticleSystemState 41 | , ManyParticleAccelerationFunction 42 | , manyParticleStateDeriv 43 | , manyParticleRungeKuttaStep 44 | 45 | -- * E&M 46 | 47 | -- ** Charge 48 | , Charge 49 | , ChargeDistribution (..) 50 | , totalCharge 51 | 52 | -- ** Current 53 | , Current 54 | , CurrentDistribution (..) 55 | 56 | -- ** Electric Field 57 | , eField 58 | 59 | -- ** Electric Flux 60 | , electricFlux 61 | 62 | -- ** Electric Potential 63 | , electricPotentialFromField 64 | , electricPotentialFromCharge 65 | 66 | -- ** Magnetic Field 67 | , bField 68 | 69 | -- ** Magnetic Flux 70 | , magneticFlux 71 | 72 | -- * Geometry 73 | 74 | -- ** Vectors 75 | , Vec 76 | , xComp 77 | , yComp 78 | , zComp 79 | , vec 80 | , (^+^) 81 | , (^-^) 82 | , (*^) 83 | , (^*) 84 | , (^/) 85 | , (<.>) 86 | , (><) 87 | , magnitude 88 | , zeroV 89 | , negateV 90 | , sumV 91 | , iHat 92 | , jHat 93 | , kHat 94 | 95 | -- ** Position 96 | , Position 97 | , Displacement 98 | , ScalarField 99 | , VectorField 100 | , Field 101 | , CoordinateSystem 102 | , cartesian 103 | , cylindrical 104 | , spherical 105 | , cart 106 | , cyl 107 | , sph 108 | , cartesianCoordinates 109 | , cylindricalCoordinates 110 | , sphericalCoordinates 111 | , displacement 112 | , shiftPosition 113 | , shiftObject 114 | , shiftField 115 | , addFields 116 | , rHat 117 | , thetaHat 118 | , phiHat 119 | , sHat 120 | , xHat 121 | , yHat 122 | , zHat 123 | 124 | -- ** Curves 125 | , Curve (..) 126 | , normalizeCurve 127 | , concatCurves 128 | , concatenateCurves 129 | , reverseCurve 130 | , evalCurve 131 | , shiftCurve 132 | , straightLine 133 | 134 | -- ** Line Integrals 135 | , simpleLineIntegral 136 | , dottedLineIntegral 137 | , crossedLineIntegral 138 | 139 | -- ** Surfaces 140 | , Surface (..) 141 | , unitSphere 142 | , centeredSphere 143 | , sphere 144 | , northernHemisphere 145 | , disk 146 | , shiftSurface 147 | 148 | -- ** Surface Integrals 149 | , surfaceIntegral 150 | , dottedSurfaceIntegral 151 | 152 | -- ** Volumes 153 | , Volume (..) 154 | , unitBall 155 | , unitBallCartesian 156 | , centeredBall 157 | , ball 158 | , northernHalfBall 159 | , centeredCylinder 160 | , shiftVolume 161 | 162 | -- ** Volume Integral 163 | , volumeIntegral 164 | 165 | -- * Differential Equations 166 | , StateSpace (..) 167 | , (.-^) 168 | , Time 169 | , DifferentialEquation 170 | , InitialValueProblem 171 | , EvolutionMethod 172 | , SolutionMethod 173 | , stepSolution 174 | , eulerMethod 175 | , rungeKutta4 176 | , integrateSystem 177 | 178 | -- * Visualization 179 | 180 | -- ** Plotting 181 | , label 182 | , postscript 183 | , psFile 184 | 185 | -- ** Gloss library 186 | , polarToCart 187 | , cartToPolar 188 | , arrow 189 | , thickArrow 190 | 191 | -- ** Vis library 192 | , v3FromVec 193 | , v3FromPos 194 | , visVec 195 | , oneVector 196 | , displayVectorField 197 | , curveObject 198 | ) 199 | where 200 | 201 | import Physics.Learn.CarrotVec 202 | ( Vec 203 | , iHat 204 | , jHat 205 | , kHat 206 | , magnitude 207 | , negateV 208 | , sumV 209 | , vec 210 | , xComp 211 | , yComp 212 | , zComp 213 | , zeroV 214 | , (*^) 215 | , (<.>) 216 | , (><) 217 | , (^*) 218 | , (^+^) 219 | , (^-^) 220 | , (^/) 221 | ) 222 | import Physics.Learn.Charge 223 | ( Charge 224 | , ChargeDistribution (..) 225 | , eField 226 | , electricFlux 227 | , electricPotentialFromCharge 228 | , electricPotentialFromField 229 | , totalCharge 230 | ) 231 | import Physics.Learn.Current 232 | ( Current 233 | , CurrentDistribution (..) 234 | , bField 235 | , magneticFlux 236 | ) 237 | import Physics.Learn.Curve 238 | ( Curve (..) 239 | , concatCurves 240 | , concatenateCurves 241 | , crossedLineIntegral 242 | , dottedLineIntegral 243 | , evalCurve 244 | , normalizeCurve 245 | , reverseCurve 246 | , shiftCurve 247 | , simpleLineIntegral 248 | , straightLine 249 | ) 250 | import Physics.Learn.Mechanics 251 | ( DSt (..) 252 | , ManyParticleAccelerationFunction 253 | , ManyParticleSystemState 254 | , OneParticleAccelerationFunction 255 | , OneParticleSystemState 256 | , SimpleAccelerationFunction 257 | , SimpleState 258 | , St (..) 259 | , TheTime 260 | , TimeStep 261 | , TwoParticleAccelerationFunction 262 | , TwoParticleSystemState 263 | , Velocity 264 | , manyParticleRungeKuttaStep 265 | , manyParticleStateDeriv 266 | , oneParticleRungeKuttaSolution 267 | , oneParticleRungeKuttaStep 268 | , oneParticleStateDeriv 269 | , simpleRungeKuttaStep 270 | , simpleStateDeriv 271 | , twoParticleRungeKuttaStep 272 | , twoParticleStateDeriv 273 | ) 274 | import Physics.Learn.Position 275 | ( CoordinateSystem 276 | , Displacement 277 | , Field 278 | , Position 279 | , ScalarField 280 | , VectorField 281 | , addFields 282 | , cart 283 | , cartesian 284 | , cartesianCoordinates 285 | , cyl 286 | , cylindrical 287 | , cylindricalCoordinates 288 | , displacement 289 | , phiHat 290 | , rHat 291 | , sHat 292 | , shiftField 293 | , shiftObject 294 | , shiftPosition 295 | , sph 296 | , spherical 297 | , sphericalCoordinates 298 | , thetaHat 299 | , xHat 300 | , yHat 301 | , zHat 302 | ) 303 | import Physics.Learn.RungeKutta 304 | ( integrateSystem 305 | , rungeKutta4 306 | ) 307 | import Physics.Learn.StateSpace 308 | ( DifferentialEquation 309 | , EvolutionMethod 310 | , InitialValueProblem 311 | , SolutionMethod 312 | , StateSpace (..) 313 | , Time 314 | , eulerMethod 315 | , stepSolution 316 | , (.-^) 317 | ) 318 | import Physics.Learn.Surface 319 | ( Surface (..) 320 | , centeredSphere 321 | , disk 322 | , dottedSurfaceIntegral 323 | , northernHemisphere 324 | , shiftSurface 325 | , sphere 326 | , surfaceIntegral 327 | , unitSphere 328 | ) 329 | import Physics.Learn.Visual.GlossTools 330 | ( arrow 331 | , cartToPolar 332 | , polarToCart 333 | , thickArrow 334 | ) 335 | import Physics.Learn.Visual.PlotTools 336 | ( label 337 | , postscript 338 | , psFile 339 | ) 340 | import Physics.Learn.Visual.VisTools 341 | ( curveObject 342 | , displayVectorField 343 | , oneVector 344 | , v3FromPos 345 | , v3FromVec 346 | , visVec 347 | ) 348 | import Physics.Learn.Volume 349 | ( Volume (..) 350 | , ball 351 | , centeredBall 352 | , centeredCylinder 353 | , northernHalfBall 354 | , shiftVolume 355 | , unitBall 356 | , unitBallCartesian 357 | , volumeIntegral 358 | ) 359 | -------------------------------------------------------------------------------- /src/Physics/Learn/AdaptiveQuadrature.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE TypeFamilies, FlexibleContexts #-} 3 | 4 | -- | Algorithm 4.2 of Burden and Faires, 5th edition 5 | 6 | module Physics.Learn.AdaptiveQuadrature 7 | -- ( adaptiveQuad 8 | -- ) 9 | where 10 | 11 | import Data.VectorSpace 12 | ( VectorSpace 13 | , InnerSpace 14 | , Scalar 15 | , (^+^) 16 | , (^-^) 17 | , (*^) 18 | , magnitude 19 | , sumV 20 | ) 21 | 22 | -- | Simplest, most elegant implementation. 23 | -- Evaluates function at same spot multiple times. 24 | adaptiveQuad :: Double -- ^ tolerance 25 | -> Double -- ^ lower limit a 26 | -> Double -- ^ upper limit b 27 | -> (Double -> Double) -- ^ function f 28 | -> Double -- ^ definite integral 29 | adaptiveQuad tol a b f 30 | = let s0 = simpson a b f 31 | m = (a + b) / 2 32 | s1a = simpson a m f 33 | s1b = simpson m b f 34 | in if abs (s1a + s1b - s0) < 10 * tol 35 | then s1a + s1b 36 | else adaptiveQuad (tol/2) a m f + adaptiveQuad (tol/2) m b f 37 | 38 | simpson :: Double -- ^ lower limit a 39 | -> Double -- ^ upper limit b 40 | -> (Double -> Double) -- ^ function f 41 | -> Double -- ^ Simpson approximation 42 | simpson a b f = (b - a) / 6 * (f a + 4 * f ((a + b) / 2) + f b) 43 | 44 | -- | Version of adaptiveQuad for vectors. 45 | -- Evaluates function at same spot multiple times. 46 | adaptiveQuadVec :: (InnerSpace v, Scalar v ~ Double) => 47 | Double -- ^ tolerance 48 | -> Double -- ^ lower limit a 49 | -> Double -- ^ upper limit b 50 | -> (Double -> v) -- ^ function f 51 | -> v -- ^ definite integral 52 | adaptiveQuadVec tol a b f 53 | = let s0 = simpsonVec a b f 54 | m = (a + b) / 2 55 | s1a = simpsonVec a m f 56 | s1b = simpsonVec m b f 57 | in if magnitude (s1a ^+^ s1b ^-^ s0) < 10 * tol 58 | then s1a ^+^ s1b 59 | else adaptiveQuadVec (tol/2) a m f ^+^ adaptiveQuadVec (tol/2) m b f 60 | 61 | -- | Version of simpson for vectors. 62 | simpsonVec :: (VectorSpace v, Scalar v ~ Double) => 63 | Double -- ^ lower limit a 64 | -> Double -- ^ upper limit b 65 | -> (Double -> v) -- ^ function f 66 | -> v -- ^ Simpson approximation 67 | simpsonVec a b f = ((b - a) / 6) *^ (f a ^+^ 4 *^ f ((a + b) / 2) ^+^ f b) 68 | 69 | -- | Burden and Faires, Example 2 on page 197 70 | example2f :: Double -> Double 71 | example2f x = (100 / x**2) * sin (10 / x) 72 | 73 | example2integral :: Double 74 | example2integral = adaptiveQuad 1e-4 1 3 example2f 75 | 76 | -- *AdaptiveQuadrature> example2integral 77 | -- -1.426014810049443 78 | 79 | -- | Does no function evaluations itself. 80 | simpleSimpson :: Double -- ^ lower limit a 81 | -> Double -- ^ upper limit b 82 | -> Double -- ^ value f(a) 83 | -> Double -- ^ value f((a+b)/2) 84 | -> Double -- ^ value f(b) 85 | -> Double -- ^ Simpson approximation 86 | simpleSimpson a b fa fm fb = (b - a) / 6 * (fa + 4 * fm + fb) 87 | 88 | -- The workhorse of the adaptive Simpson method. 89 | -- Called by adaptiveSimpson 90 | adaptiveSimpsonStep :: Double -- ^ tolerance 91 | -> Double -- ^ lower limit a 92 | -> Double -- ^ upper limit b 93 | -> (Double -> Double) -- ^ function f 94 | -> Double -- ^ value f(a) 95 | -> Double -- ^ value f((a+b)/2) 96 | -> Double -- ^ value f(b) 97 | -> Double -- ^ definite integral 98 | adaptiveSimpsonStep tol a b f fa fm fb 99 | = let s0 = simpleSimpson a b fa fm fb 100 | m = (a + b) / 2 101 | am = (a + m) / 2 102 | mb = (m + b) / 2 103 | fam = f am 104 | fmb = f mb 105 | s1a = simpleSimpson a m fa fam fm 106 | s1b = simpleSimpson m b fm fmb fb 107 | in if abs (s1a + s1b - s0) < 10 * tol 108 | then s1a + s1b 109 | else adaptiveSimpsonStep (tol/2) a m f fa fam fm + adaptiveSimpsonStep (tol/2) m b f fm fmb fb 110 | 111 | -- | This version is more efficient in that it does not 112 | -- repeat function evaluations. 113 | adaptiveSimpson :: Double -- ^ tolerance 114 | -> Double -- ^ lower limit a 115 | -> Double -- ^ upper limit b 116 | -> (Double -> Double) -- ^ function f 117 | -> Double -- ^ definite integral 118 | adaptiveSimpson tol a b f 119 | = let fa = f a 120 | m = (a + b) / 2 121 | fm = f m 122 | fb = f b 123 | in adaptiveSimpsonStep tol a b f fa fm fb 124 | 125 | -- | Does no function evaluations itself. 126 | -- For vector functions. 127 | simpleSimpsonVec :: (VectorSpace v, Fractional (Scalar v)) => 128 | Scalar v -- ^ lower limit a 129 | -> Scalar v -- ^ upper limit b 130 | -> v -- ^ value f(a) 131 | -> v -- ^ value f((a+b)/2) 132 | -> v -- ^ value f(b) 133 | -> v -- ^ Simpson approximation 134 | simpleSimpsonVec a b fa fm fb = ((b - a) / 6) *^ (fa ^+^ 4 *^ fm ^+^ fb) 135 | 136 | ------------------------------------------ 137 | -- Resource-limited adaptive quadrature -- 138 | ------------------------------------------ 139 | 140 | {- 141 | Want a version that gives an error estimate, and can be used by 142 | a scheduler for a resource-limited adaptive algorithm. 143 | We won't achieve a desired precision, but rather we'll use 144 | a fixed amount of resources in the best way possible. 145 | 146 | I think we'll need to create a data structure to hold the results 147 | of evaluations so far so that they can be fed to the next step 148 | if necessary. 149 | 150 | -- | This version does not repeat function evaluations. 151 | -- It provides an error estimate. 152 | 153 | 154 | -} 155 | 156 | -- data EvPair v = EvPair (Scalar v) v 157 | 158 | data SimpInterval3 v = SI3 { prLo :: (Scalar v, v) 159 | , prMi :: (Scalar v, v) 160 | , prHi :: (Scalar v, v) 161 | , intEst3 :: v 162 | } 163 | 164 | data SimpInterval5 v = SI5 { pr0 :: (Scalar v, v) 165 | , pr1 :: (Scalar v, v) 166 | , pr2 :: (Scalar v, v) 167 | , pr3 :: (Scalar v, v) 168 | , pr4 :: (Scalar v, v) 169 | , intEst012 :: v 170 | , intEst234 :: v 171 | , intEst024 :: v 172 | , integralEst :: v -- sum of intEst012 and intEst234 173 | , errorEst :: Scalar v 174 | } 175 | 176 | divideInterval :: SimpInterval5 v -> (SimpInterval3 v, SimpInterval3 v) 177 | divideInterval (SI5 xy0 xy1 xy2 xy3 xy4 ie012 ie234 _ie024 _ _) 178 | = (SI3 xy0 xy1 xy2 ie012, SI3 xy2 xy3 xy4 ie234) 179 | 180 | refineInterval :: (InnerSpace v , Floating (Scalar v)) => 181 | (Scalar v -> v) 182 | -> SimpInterval3 v 183 | -> SimpInterval5 v 184 | refineInterval f (SI3 (x0,y0) (x2,y2) (x4,y4) ie024) 185 | = let x1 = (x0 + x2) / 2 186 | x3 = (x2 + x4) / 2 187 | y1 = f x1 188 | y3 = f x3 189 | ie012 = simpleSimpsonVec x0 x2 y0 y1 y2 190 | ie234 = simpleSimpsonVec x2 x4 y2 y3 y4 191 | ie = ie012 ^+^ ie234 192 | errEst = 1/10 * magnitude (ie ^-^ ie024) -- 1/10 instead of 1/15 193 | in SI5 (x0,y0) (x1,y1) (x2,y2) (x3,y3) (x4,y4) ie012 ie234 ie024 ie errEst 194 | 195 | divideWorstInterval :: (InnerSpace v, Ord (Scalar v), Floating (Scalar v)) => 196 | (Scalar v -> v) 197 | -> [SimpInterval5 v] 198 | -> [SimpInterval5 v] 199 | divideWorstInterval _ [] = error "divideWorstInterval should never have been called on an empty list" 200 | divideWorstInterval f (si:sis) 201 | = let (si3a,si3b) = divideInterval si 202 | si5a = refineInterval f si3a 203 | si5b = refineInterval f si3b 204 | in insertSorted si5a $ insertSorted si5b sis 205 | 206 | insertSorted :: Ord (Scalar v) => 207 | SimpInterval5 v 208 | -> [SimpInterval5 v] 209 | -> [SimpInterval5 v] 210 | insertSorted si5 [] = [si5] 211 | insertSorted si5 (si:sis) = if errorEst si5 > errorEst si 212 | then si5:si:sis 213 | else si:insertSorted si5 sis 214 | 215 | adaptiveSimpEvalLimit :: (InnerSpace v, Ord (Scalar v), Floating (Scalar v)) => 216 | Int -- ^ approximate number of function evals 217 | -> Scalar v -- ^ lower limit 218 | -> Scalar v -- ^ upper limit 219 | -> (Scalar v -> v) -- ^ scalar or vector function 220 | -> v -- ^ approximate integral 221 | adaptiveSimpEvalLimit n a b f 222 | = let m = (a + b) / 2 223 | fa = f a 224 | fm = f m 225 | fb = f b 226 | ie = simpleSimpsonVec a b fa fm fb 227 | si3 = SI3 (a,fa) (m,fm) (b,fb) ie 228 | si5 = refineInterval f si3 229 | in sumV $ map integralEst $ last $ take (div n 4) $ iterate (divideWorstInterval f) [si5] 230 | 231 | {- 232 | data SimpsonInterval5 v = SI5 { pLo :: Scalar v 233 | , pHi :: Scalar v 234 | , fLo :: v 235 | , fLM :: v 236 | , fM :: v 237 | , fMH :: v 238 | , fHi :: v 239 | , integralEst :: v 240 | , errorEst :: Scalar v 241 | } 242 | -} 243 | 244 | ------------------------------- 245 | -- Two-Dimensional integrals -- 246 | ------------------------------- 247 | 248 | adaptiveQuad2D :: Double -- ^ tolerance 249 | -> Double -- ^ lower limit x_0 250 | -> Double -- ^ upper limit x_1 251 | -> (Double -> Double) -- ^ lower limit y_0(x) 252 | -> (Double -> Double) -- ^ upper limit y_1(x) 253 | -> (Double -> Double -> Double) -- ^ function f 254 | -> Double -- ^ definite integral 255 | adaptiveQuad2D tol x0 x1 y0 y1 f 256 | = let f1 x = adaptiveQuad tol' (y0 x) (y1 x) (f x) 257 | tol' = tol / abs (x1 - x0) 258 | in adaptiveQuad tol x0 x1 f1 259 | 260 | aq2dTest :: Double -> Double 261 | aq2dTest tol = adaptiveQuad2D tol (-1) 1 (\y -> -sqrt(1 - y**2)) (\y -> sqrt(1-y**2)) (\_ _ -> 1) 262 | 263 | adaptiveSimpson2D :: Double -- ^ tolerance 264 | -> Double -- ^ lower limit x_0 265 | -> Double -- ^ upper limit x_1 266 | -> (Double -> Double) -- ^ lower limit y_0(x) 267 | -> (Double -> Double) -- ^ upper limit y_1(x) 268 | -> (Double -> Double -> Double) -- ^ function f 269 | -> Double -- ^ definite integral 270 | adaptiveSimpson2D tol x0 x1 y0 y1 f 271 | = let f1 x = adaptiveSimpson tol' (y0 x) (y1 x) (f x) 272 | tol' = tol / abs (x1 - x0) 273 | in adaptiveSimpson tol x0 x1 f1 274 | 275 | adaptiveSimpson3D :: Double -- ^ tolerance 276 | -> Double -- ^ lower limit x_0 277 | -> Double -- ^ upper limit x_1 278 | -> (Double -> Double) -- ^ lower limit y_0(x) 279 | -> (Double -> Double) -- ^ upper limit y_1(x) 280 | -> (Double -> Double -> Double) -- ^ lower limit z_0(x,y) 281 | -> (Double -> Double -> Double) -- ^ upper limit z_1(x,y) 282 | -> (Double -> Double -> Double -> Double) -- ^ function f 283 | -> Double -- ^ definite integral 284 | adaptiveSimpson3D tol x0 x1 y0 y1 z0 z1 f 285 | = let f1 x = adaptiveSimpson2D tol' (y0 x) (y1 x) (z0 x) (z1 x) (f x) 286 | tol' = tol / abs (x1 - x0) 287 | in adaptiveSimpson tol x0 x1 f1 288 | 289 | as3dTest :: Double -> Double 290 | as3dTest tol = adaptiveSimpson3D tol (-1) 1 291 | (\y -> -sqrt(1 - y**2)) (\y -> sqrt(1-y**2)) 292 | (\x y -> -sqrt(1 - x**2 - y**2)) (\x y -> sqrt(1 - x**2 - y**2)) 293 | (\_ _ _ -> 1) 294 | 295 | -------------------------------------------------------------------------------- /src/Physics/Learn/BeamStack.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE Trustworthy #-} 3 | {-# LANGUAGE CPP #-} 4 | 5 | {- | 6 | Module : Physics.Learn.BeamStack 7 | Copyright : (c) Scott N. Walck 2016-2018 8 | License : BSD3 (see LICENSE) 9 | Maintainer : Scott N. Walck 10 | Stability : experimental 11 | 12 | Splitters, recombiners, and detectors for Stern-Gerlach 13 | experiments. 14 | -} 15 | 16 | -- Spin-1/2 mixed states. 17 | 18 | module Physics.Learn.BeamStack 19 | ( 20 | -- * Core laboratory components 21 | BeamStack() 22 | , randomBeam 23 | , split 24 | , recombine 25 | , applyBField 26 | , dropBeam 27 | , flipBeams 28 | , numBeams 29 | , detect 30 | -- * Standard splitters 31 | , splitX 32 | , splitY 33 | , splitZ 34 | -- * Standard magnetic fields 35 | , applyBFieldX 36 | , applyBFieldY 37 | , applyBFieldZ 38 | -- * Standard combiners 39 | , recombineX 40 | , recombineY 41 | , recombineZ 42 | -- * Filters 43 | , xpFilter 44 | , xmFilter 45 | , zpFilter 46 | , zmFilter 47 | ) 48 | where 49 | 50 | import Physics.Learn.QuantumMat 51 | ( zp 52 | , zm 53 | , nm 54 | , np 55 | , couter 56 | , oneQubitMixed 57 | ) 58 | import Numeric.LinearAlgebra 59 | ( C 60 | , Vector 61 | , Matrix 62 | , iC 63 | , (<>) 64 | , kronecker 65 | , fromLists 66 | , toList 67 | , toLists 68 | , scale 69 | , size 70 | , takeDiag 71 | , ident 72 | , tr 73 | ) 74 | import Data.Complex 75 | ( Complex(..) 76 | , realPart 77 | , imagPart 78 | ) 79 | import Data.List 80 | ( intercalate 81 | ) 82 | #if MIN_VERSION_base(4,11,0) 83 | import Prelude hiding ((<>)) 84 | #endif 85 | 86 | data BeamStack = BeamStack (Matrix C) 87 | 88 | showOneBeam :: Double -> String 89 | showOneBeam r = "Beam of intensity " ++ show r 90 | 91 | instance Show BeamStack where 92 | show b = intercalate "\n" $ map showOneBeam (detect b) 93 | 94 | {- 95 | unBeamStack :: BeamStack -> Matrix C 96 | unBeamStack (BeamStack m) = m 97 | -} 98 | 99 | -------------------- 100 | -- Core functions -- 101 | -------------------- 102 | 103 | -- | A beam of randomly oriented spin-1/2 particles. 104 | randomBeam :: BeamStack 105 | randomBeam = BeamStack oneQubitMixed 106 | 107 | extendWithZeros :: Matrix C -> Matrix C 108 | extendWithZeros m 109 | = let (_,q) = size m 110 | ml = toLists m 111 | in fromLists $ map (++ [0,0]) ml 112 | ++ [replicate (q+2) 0, replicate (q+2) 0] 113 | 114 | -- reduce row and column size by 2 115 | reduceMat :: Matrix C -> Matrix C 116 | reduceMat m 117 | = let (p,q) = size m 118 | ml = toLists m 119 | in fromLists $ take (p-2) $ map (take (q-2)) ml 120 | 121 | checkedRealPart :: C -> Double 122 | checkedRealPart c 123 | = let eps = 1e-14 124 | in if imagPart c < eps 125 | then realPart c 126 | else error $ "checkRealPart: imagPart = " ++ show (imagPart c) 127 | 128 | -- | Return the intensities of a stack of beams. 129 | detect :: BeamStack -> [Double] 130 | detect (BeamStack m) 131 | = addAlternate $ toList $ takeDiag m 132 | 133 | addAlternate :: [C] -> [Double] 134 | addAlternate [] = [] 135 | addAlternate [_] = error "addAlternate needs even number of elements" 136 | addAlternate (x:y:xs) = checkedRealPart (x+y) : addAlternate xs 137 | 138 | -- | Remove the most recent beam from the stack. 139 | dropBeam :: BeamStack -> BeamStack 140 | dropBeam (BeamStack m) = BeamStack (reduceMat m) 141 | 142 | -- | Return the number of beams in a 'BeamStack'. 143 | numBeams :: BeamStack -> Int 144 | numBeams (BeamStack m) 145 | = let (p,_) = size m 146 | in p `div` 2 147 | 148 | -- | Interchange the two most recent beams on the stack. 149 | flipBeams :: BeamStack -> BeamStack 150 | flipBeams (BeamStack m) 151 | = let (d,_) = size m 152 | fl = flipMat d 153 | in BeamStack $ fl <> m <> tr fl 154 | 155 | flipMat :: Int -> Matrix C 156 | flipMat d = bigM d (fromLists [[0,0,1,0] 157 | ,[0,0,0,1] 158 | ,[1,0,0,0] 159 | ,[0,1,0,0]]) 160 | 161 | -- Turn a 2x2 into a dxd. 162 | bigM2 :: Int -> Matrix C -> Matrix C 163 | bigM2 d m 164 | | d < 2 = error "bigM2 requires d >= 2" 165 | | odd d = error "bigM2 requires even d" 166 | | otherwise = fromLists $ map (++ [0,0]) (toLists (ident (d-2))) 167 | ++ map (replicate (d-2) 0 ++) (toLists m) 168 | 169 | -- Turn a 4x4 into a dxd. 170 | bigM :: Int -> Matrix C -> Matrix C 171 | bigM d m 172 | | d < 4 = error "bigM requires d >= 4" 173 | | odd d = error "bigM requires even d" 174 | | otherwise = fromLists $ map (++ [0,0,0,0]) (toLists (ident (d-4))) 175 | ++ map (replicate (d-4) 0 ++) (toLists m) 176 | 177 | s :: Double -> Double -> Matrix C 178 | s theta phi = kronecker (u `couter` u) (np theta phi `couter` np theta phi) 179 | + kronecker (l `couter` u) (nm theta phi `couter` nm theta phi) 180 | + kronecker (u `couter` l) (nm theta phi `couter` nm theta phi) 181 | + kronecker (l `couter` l) (np theta phi `couter` np theta phi) 182 | 183 | u :: Vector C 184 | u = zp 185 | 186 | l :: Vector C 187 | l = zm 188 | 189 | -- | Given angles describing the orientation of the splitter, 190 | -- removes an incoming beam from the stack and replaces 191 | -- it with two beams, a spin-up and a spin-down beam. 192 | -- The spin-down beam is the most recent beam on the stack. 193 | split :: Double -> Double -> BeamStack -> BeamStack 194 | split theta phi (BeamStack m) 195 | = let m' = extendWithZeros m 196 | (p,_) = size m' 197 | ss = bigM p (s theta phi) 198 | in BeamStack $ ss <> m' <> tr ss 199 | 200 | -- | Given angles describing the orientation of the recombiner, 201 | -- returns a single beam from an incoming pair of beams. 202 | recombine :: Double -> Double -> BeamStack -> BeamStack 203 | recombine theta phi (BeamStack m) 204 | = let (d,_) = size m 205 | ss = bigM d (s theta phi) 206 | in dropBeam $ BeamStack $ ss <> m <> tr ss 207 | 208 | mag2x2 :: Double -> Double -> Double -> Matrix C 209 | mag2x2 theta phi omegaT 210 | = let z = iC * (omegaT :+ 0) / 2 211 | np' = np theta phi 212 | nm' = nm theta phi 213 | in scale (exp z ) (np' `couter` np') 214 | + scale (exp (-z)) (nm' `couter` nm') 215 | 216 | -- | Given angles describing the direction of a 217 | -- uniform magnetic field, and given an angle 218 | -- describing the product of the Larmor frequency 219 | -- and the time, return an output beam from an 220 | -- input beam. 221 | applyBField :: Double -> Double -> Double -> BeamStack -> BeamStack 222 | applyBField theta phi omegaT (BeamStack m) 223 | = let (d,_) = size m 224 | uu = bigM2 d (mag2x2 theta phi omegaT) 225 | in BeamStack $ uu <> m <> tr uu 226 | 227 | ----------------------- 228 | -- Derived functions -- 229 | ----------------------- 230 | 231 | -- | A Stern-Gerlach splitter in the x direction. 232 | splitX :: BeamStack -> BeamStack 233 | splitX = split (pi/2) 0 234 | 235 | -- | A Stern-Gerlach splitter in the y direction. 236 | splitY :: BeamStack -> BeamStack 237 | splitY = split (pi/2) (pi/2) 238 | 239 | -- | A Stern-Gerlach splitter in the z direction. 240 | splitZ :: BeamStack -> BeamStack 241 | splitZ = split 0 0 242 | 243 | -- | Given an angle in radians 244 | -- describing the product of the Larmor frequency 245 | -- and the time, apply a magnetic in the x direction 246 | -- to the most recent beam on the stack. 247 | applyBFieldX :: Double -> BeamStack -> BeamStack 248 | applyBFieldX = applyBField (pi/2) 0 249 | 250 | -- | Given an angle in radians 251 | -- describing the product of the Larmor frequency 252 | -- and the time, apply a magnetic in the y direction 253 | -- to the most recent beam on the stack. 254 | applyBFieldY :: Double -> BeamStack -> BeamStack 255 | applyBFieldY = applyBField (pi/2) (pi/2) 256 | 257 | -- | Given an angle in radians 258 | -- describing the product of the Larmor frequency 259 | -- and the time, apply a magnetic in the z direction 260 | -- to the most recent beam on the stack. 261 | applyBFieldZ :: Double -> BeamStack -> BeamStack 262 | applyBFieldZ = applyBField 0 0 263 | 264 | -- | A Stern-Gerlach recombiner in the x direction. 265 | recombineX :: BeamStack -> BeamStack 266 | recombineX = recombine (pi/2) 0 267 | 268 | -- | A Stern-Gerlach recombiner in the y direction. 269 | recombineY :: BeamStack -> BeamStack 270 | recombineY = recombine (pi/2) (pi/2) 271 | 272 | -- | A Stern-Gerlach recombiner in the z direction. 273 | recombineZ :: BeamStack -> BeamStack 274 | recombineZ = recombine 0 0 275 | 276 | -- | Filter for spin-up particles in the x direction. 277 | xpFilter :: BeamStack -> BeamStack 278 | xpFilter = dropBeam . splitX 279 | 280 | -- | Filter for spin-down particles in the x direction. 281 | xmFilter :: BeamStack -> BeamStack 282 | xmFilter = dropBeam . flipBeams . splitX 283 | 284 | -- | Filter for spin-up particles in the z direction. 285 | zpFilter :: BeamStack -> BeamStack 286 | zpFilter = dropBeam . splitZ 287 | 288 | -- | Filter for spin-down particles in the z direction. 289 | zmFilter :: BeamStack -> BeamStack 290 | zmFilter = dropBeam . flipBeams . splitZ 291 | -------------------------------------------------------------------------------- /src/Physics/Learn/BlochSphere.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE CPP #-} 3 | 4 | {- | 5 | Module : Physics.Learn.BlochSphere 6 | Copyright : (c) Scott N. Walck 2016 7 | License : BSD3 (see LICENSE) 8 | Maintainer : Scott N. Walck 9 | Stability : experimental 10 | 11 | This module contains functions for displaying the 12 | state of a spin-1/2 particle or other quantum two-level 13 | system as a point on the Bloch Sphere. 14 | -} 15 | 16 | module Physics.Learn.BlochSphere 17 | ( VisObj 18 | , toPos 19 | , ketToPos 20 | , staticBlochSphere 21 | , displayStaticState 22 | , animatedBlochSphere 23 | , simulateBlochSphere 24 | , simulateBlochSphereK 25 | , stateProp 26 | , statePropK 27 | , evolutionBlochSphere 28 | , evolutionBlochSphereK 29 | , hamRabi 30 | ) 31 | where 32 | 33 | import qualified Physics.Learn.QuantumMat as M 34 | import qualified Physics.Learn.Ket as K 35 | import Physics.Learn.Ket 36 | ( Ket 37 | , Operator 38 | , (<>) 39 | , dagger 40 | ) 41 | import Numeric.LinearAlgebra 42 | ( Vector 43 | , Matrix 44 | , C 45 | , iC 46 | -- , (<>) -- matrix multiplication 47 | -- , (|>) -- vector definition 48 | , (!) -- vector element access 49 | , (><) -- matrix definition 50 | , scale 51 | , size 52 | ) 53 | import Data.Complex 54 | ( Complex(..) 55 | , conjugate 56 | , realPart 57 | , imagPart 58 | ) 59 | import Physics.Learn 60 | ( Position 61 | , v3FromPos 62 | , cart 63 | ) 64 | import SpatialMath 65 | ( Euler(..) 66 | ) 67 | import Vis 68 | ( VisObject(..) 69 | , Flavour(..) 70 | , Options(..) 71 | , Camera0(..) 72 | , defaultOpts 73 | , display 74 | , simulate 75 | , blue 76 | , red 77 | ) 78 | #if MIN_VERSION_base(4,11,0) 79 | import Prelude hiding ((<>)) 80 | #endif 81 | 82 | {- 83 | 3 ways to specify the state of a spin-1/2 particle: 84 | Vector C 85 | Ket 86 | Position (Bloch vector) 87 | 88 | 2 ways to specify a Hamiltonian: 89 | Matrix C 90 | Operator 91 | 92 | 3 choices for Vis' world: 93 | (Float, Vector C) 94 | (Float, Ket) 95 | (Float, Position) 96 | -} 97 | 98 | -- | A Vis object. 99 | type VisObj = VisObject Double 100 | 101 | -- | Convert a 2x1 complex state vector for a qubit 102 | -- into Bloch (x,y,z) coordinates. 103 | toPos :: Vector C -> Position 104 | toPos v 105 | = if size v /= 2 106 | then error "toPos only for size 2 vectors" 107 | else let z1 = v ! 0 108 | z2 = v ! 1 109 | in cart (2 * realPart (conjugate z1 * z2)) 110 | (2 * imagPart (conjugate z1 * z2)) 111 | (realPart (conjugate z1 * z1 - conjugate z2 * z2)) 112 | 113 | -- | Convert a qubit ket 114 | -- into Bloch (x,y,z) coordinates. 115 | ketToPos :: Ket -> Position 116 | ketToPos psi 117 | = if K.dim psi /= 2 118 | then error "ketToPos only for qubit kets" 119 | else let z1 = dagger K.zp <> psi 120 | z2 = dagger K.zm <> psi 121 | in cart (2 * realPart (conjugate z1 * z2)) 122 | (2 * imagPart (conjugate z1 * z2)) 123 | (realPart (conjugate z1 * z1 - conjugate z2 * z2)) 124 | 125 | -- | A static 'VisObj' for the state of a qubit. 126 | staticBlochSphere :: Position -> VisObj 127 | staticBlochSphere r 128 | = RotEulerDeg (Euler 270 0 0) $ RotEulerDeg (Euler 0 180 0) $ 129 | VisObjects [ Sphere 1 Wireframe blue 130 | , Trans (v3FromPos r) (Sphere 0.05 Solid red) 131 | ] 132 | 133 | displayStaticBlochSphere :: Position -> IO () 134 | displayStaticBlochSphere r 135 | = display myOptions (staticBlochSphere r) 136 | 137 | -- | Display a qubit state vector as a point on the Bloch Sphere. 138 | displayStaticState :: Vector C -> IO () 139 | displayStaticState = displayStaticBlochSphere . toPos 140 | 141 | -- | Given a Bloch vector as a function of time, 142 | -- return a 'VisObj' as a function of time. 143 | animatedBlochSphere :: (Double -> Position) -> (Float -> VisObj) 144 | animatedBlochSphere f 145 | = staticBlochSphere . f . realToFrac 146 | 147 | -- | Given a sample rate, initial qubit state vector, and 148 | -- state propagation function, produce a simulation. 149 | -- The 'Float' in the state propagation function is the time 150 | -- since the beginning of the simulation. 151 | simulateBlochSphere :: Double -> Vector C -> (Float -> (Float,Vector C) -> (Float,Vector C)) -> IO () 152 | simulateBlochSphere sampleRate initial statePropFunc 153 | = simulate myOptions sampleRate (0,initial) (staticBlochSphere . toPos . snd) statePropFunc 154 | 155 | -- | Given a sample rate, initial qubit state ket, and 156 | -- state propagation function, produce a simulation. 157 | -- The 'Float' in the state propagation function is the time 158 | -- since the beginning of the simulation. 159 | simulateBlochSphereK :: Double -> Ket -> (Float -> (Float,Ket) -> (Float,Ket)) -> IO () 160 | simulateBlochSphereK sampleRate initial statePropFuncK 161 | = simulate myOptions sampleRate (0,initial) (staticBlochSphere . ketToPos . snd) statePropFuncK 162 | 163 | {- 164 | -- | Given a sample rate, initial qubit state vector, and 165 | -- state propagation function, produce a simulation. 166 | -- The 'Float' in the state propagation function is the time 167 | -- since the beginning of the simulation. 168 | playBlochSphere :: Double -> Vector C -> (Float -> (Float,Vector C) -> (Float,Vector C)) -> IO () 169 | playBlochSphere sampleRate initial statePropFunc 170 | = play myOptions sampleRate (0,initial) (staticBlochSphere . toPos . snd) statePropFunc 171 | -} 172 | 173 | -- | Produce a state propagation function from a time-dependent Hamiltonian. 174 | stateProp :: (Double -> Matrix C) -> Float -> (Float,Vector C) -> (Float,Vector C) 175 | stateProp ham tNew (tOld,v) 176 | = (tNew, M.timeEv (realToFrac dt) (ham tMid) v) 177 | where 178 | dt = tNew - tOld 179 | tMid = realToFrac $ (tNew + tOld) / 2 180 | 181 | -- | Produce a state propagation function from a time-dependent Hamiltonian. 182 | statePropK :: (Double -> Operator) -> Float -> (Float,Ket) -> (Float,Ket) 183 | statePropK ham tNew (tOld,psi) 184 | = (tNew, K.timeEv (realToFrac dt) (ham tMid) psi) 185 | where 186 | dt = tNew - tOld 187 | tMid = realToFrac $ (tNew + tOld) / 2 188 | 189 | -- | Given an initial qubit state and a time-dependent Hamiltonian, 190 | -- produce a visualization. 191 | evolutionBlochSphere :: Vector C -> (Double -> Matrix C) -> IO () 192 | evolutionBlochSphere psi0 ham 193 | = simulateBlochSphere 0.01 psi0 (stateProp ham) 194 | 195 | -- | Given an initial qubit ket and a time-dependent Hamiltonian, 196 | -- produce a visualization. 197 | evolutionBlochSphereK :: Ket -> (Double -> Operator) -> IO () 198 | evolutionBlochSphereK psi0 ham 199 | = simulateBlochSphereK 0.01 psi0 (statePropK ham) 200 | 201 | myOptions :: Options 202 | myOptions = defaultOpts {optWindowName = "Bloch Sphere" 203 | ,optInitialCamera = Just (Camera0 75 20 4)} 204 | 205 | {- 206 | staticBz1 :: IO () 207 | staticBz1 = evolutionBlochSphere M.xp (const (scale 0.9 M.sz)) 208 | 209 | staticBz2 :: IO () 210 | staticBz2 = evolutionBlochSphere ((2|>) [(cos (pi / 8)), (sin (pi / 8))]) (const M.sz) 211 | 212 | staticBy1 :: IO () 213 | staticBy1 = evolutionBlochSphere M.xp (const M.sy) 214 | -} 215 | 216 | -- | Hamiltonian for nuclear magnetic resonance. 217 | -- Explain omega0, omegaR, omega. 218 | hamRabi :: Double -> Double -> Double -> Double -> Matrix C 219 | hamRabi omega0 omegaR omega t 220 | = let h11 = omega0 :+ 0 221 | h12 = (omegaR :+ 0) * exp (-iC * ((omega * t) :+ 0)) 222 | in scale (1/2) $ (2><2) [h11, h12, (conjugate h12), (-h11)] 223 | 224 | -- need to scale time 225 | 226 | -- a pi pulse 227 | -------------------------------------------------------------------------------- /src/Physics/Learn/CarrotVec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} 3 | {-# LANGUAGE Safe #-} 4 | 5 | {- | 6 | Module : Physics.Learn.CarrotVec 7 | Copyright : (c) Scott N. Walck 2011-2019 8 | License : BSD3 (see LICENSE) 9 | Maintainer : Scott N. Walck 10 | Stability : experimental 11 | 12 | This module defines some basic vector functionality. 13 | It uses the same internal data representation as 'SimpleVec', 14 | but declares 'Vec' to be an instance of 'VectorSpace'. 15 | We import 'zeroV', 'negateV', 'sumV', '^+^', '^-^' 16 | from 'AdditiveGroup', and 17 | '*^', '^*', '^/', '<.>', 'magnitude' 18 | from 'VectorSpace'. 19 | 20 | 'CarrotVec' exports exactly the same symbols as 'SimpleVec'; 21 | they are just defined differently. 22 | -} 23 | 24 | -- 2011 Apr 10 25 | -- Definitions common to SimpleVec and CarrotVec have been put in CommonVec. 26 | 27 | module Physics.Learn.CarrotVec 28 | ( Vec 29 | , R 30 | , xComp 31 | , yComp 32 | , zComp 33 | , vec 34 | , (^+^) 35 | , (^-^) 36 | , (*^) 37 | , (^*) 38 | , (^/) 39 | , (<.>) 40 | , (><) 41 | , magnitude 42 | , zeroV 43 | , negateV 44 | , sumV 45 | , iHat 46 | , jHat 47 | , kHat 48 | ) 49 | where 50 | 51 | import Data.VectorSpace 52 | ( VectorSpace(..) 53 | , InnerSpace(..) 54 | , AdditiveGroup(..) 55 | , Scalar 56 | , (^+^) 57 | , (^-^) 58 | , (*^) 59 | , (^*) 60 | , (^/) 61 | , (<.>) 62 | , magnitude 63 | , zeroV 64 | , negateV 65 | , sumV 66 | ) 67 | import Physics.Learn.CommonVec 68 | ( Vec(..) 69 | , R 70 | , xComp 71 | , yComp 72 | , zComp 73 | , vec 74 | , (><) 75 | , iHat 76 | , jHat 77 | , kHat 78 | ) 79 | 80 | instance AdditiveGroup Vec where 81 | zeroV = vec 0 0 0 82 | negateV (Vec ax ay az) = Vec (-ax) (-ay) (-az) 83 | Vec ax ay az ^+^ Vec bx by bz = Vec (ax+bx) (ay+by) (az+bz) 84 | 85 | instance VectorSpace Vec where 86 | type Scalar Vec = R 87 | c *^ Vec ax ay az = Vec (c*ax) (c*ay) (c*az) 88 | 89 | instance InnerSpace Vec where 90 | Vec ax ay az <.> Vec bx by bz = ax*bx + ay*by + az*bz 91 | 92 | -------------------------------------------------------------------------------- /src/Physics/Learn/Charge.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE Safe #-} 3 | 4 | {- | 5 | Module : Physics.Learn.Charge 6 | Copyright : (c) Scott N. Walck 2011-2019 7 | License : BSD3 (see LICENSE) 8 | Maintainer : Scott N. Walck 9 | Stability : experimental 10 | 11 | This module contains functions for working with charge, electric field, 12 | electric flux, and electric potential. 13 | -} 14 | 15 | module Physics.Learn.Charge 16 | ( 17 | -- * Charge 18 | Charge 19 | , ChargeDistribution(..) 20 | , totalCharge 21 | -- * Electric Field 22 | , eField 23 | , eFieldFromPointCharge 24 | , eFieldFromLineCharge 25 | , eFieldFromSurfaceCharge 26 | , eFieldFromVolumeCharge 27 | -- * Electric Flux 28 | , electricFlux 29 | -- * Electric Potential 30 | , electricPotentialFromField 31 | , electricPotentialFromCharge 32 | ) 33 | where 34 | 35 | import Physics.Learn.CarrotVec 36 | ( magnitude 37 | , (*^) 38 | , (^/) 39 | ) 40 | import Physics.Learn.Position 41 | ( Position 42 | , ScalarField 43 | , VectorField 44 | , displacement 45 | , addFields 46 | ) 47 | import Physics.Learn.Curve 48 | ( Curve(..) 49 | , straightLine 50 | , simpleLineIntegral 51 | , dottedLineIntegral 52 | ) 53 | import Physics.Learn.Surface 54 | ( Surface(..) 55 | , surfaceIntegral 56 | , dottedSurfaceIntegral 57 | ) 58 | import Physics.Learn.Volume 59 | ( Volume(..) 60 | , volumeIntegral 61 | ) 62 | 63 | -- | Electric charge, in units of Coulombs (C) 64 | type Charge = Double 65 | 66 | -- | A charge distribution is a point charge, a line charge, a surface charge, 67 | -- a volume charge, or a combination of these. 68 | -- The 'ScalarField' describes a linear charge density, a surface charge density, 69 | -- or a volume charge density. 70 | data ChargeDistribution = PointCharge Charge Position -- ^ point charge 71 | | LineCharge ScalarField Curve -- ^ 'ScalarField' is linear charge density (C/m) 72 | | SurfaceCharge ScalarField Surface -- ^ 'ScalarField' is surface charge density (C/m^2) 73 | | VolumeCharge ScalarField Volume -- ^ 'ScalarField' is volume charge density (C/m^3) 74 | | MultipleCharges [ChargeDistribution] -- ^ combination of charge distributions 75 | 76 | -- | Total charge (in C) of a charge distribution. 77 | totalCharge :: ChargeDistribution -> Charge 78 | totalCharge (PointCharge q _) = q 79 | totalCharge (LineCharge lambda c) = simpleLineIntegral 1000 lambda c 80 | totalCharge (SurfaceCharge sigma s) = surfaceIntegral 200 200 sigma s 81 | totalCharge (VolumeCharge rho v) = volumeIntegral 50 50 50 rho v 82 | totalCharge (MultipleCharges ds) = sum [totalCharge d | d <- ds] 83 | 84 | {- 85 | shiftChargeDistribution :: Displacement -> ChargeDistribution -> ChargeDistribution 86 | shiftChargeDistribution d (Point 87 | -} 88 | 89 | -- | Electric field produced by a point charge. 90 | -- The function 'eField' calls this function 91 | -- to evaluate the electric field produced by a point charge. 92 | eFieldFromPointCharge 93 | :: Charge -- ^ charge (in Coulombs) 94 | -> Position -- ^ of point charge 95 | -> VectorField -- ^ electric field (in V/m) 96 | eFieldFromPointCharge q r' r 97 | = (k * q) *^ d ^/ magnitude d ** 3 98 | where 99 | k = 9e9 -- 1 / (4 * pi * epsilon0) 100 | d = displacement r' r 101 | 102 | -- | Electric field produced by a line charge. 103 | -- The function 'eField' calls this function 104 | -- to evaluate the electric field produced by a line charge. 105 | eFieldFromLineCharge 106 | :: ScalarField -- ^ linear charge density lambda 107 | -> Curve -- ^ geometry of the line charge 108 | -> VectorField -- ^ electric field (in V/m) 109 | eFieldFromLineCharge lambda c r 110 | = k *^ simpleLineIntegral 1000 integrand c 111 | where 112 | k = 9e9 -- 1 / (4 * pi * epsilon0) 113 | integrand r' = lambda r' *^ d ^/ magnitude d ** 3 114 | where 115 | d = displacement r' r 116 | 117 | -- | Electric field produced by a surface charge. 118 | -- The function 'eField' calls this function 119 | -- to evaluate the electric field produced by a surface charge. 120 | eFieldFromSurfaceCharge 121 | :: ScalarField -- ^ surface charge density sigma 122 | -> Surface -- ^ geometry of the surface charge 123 | -> VectorField -- ^ electric field (in V/m) 124 | eFieldFromSurfaceCharge sigma s r 125 | = k *^ surfaceIntegral 200 200 integrand s 126 | where 127 | k = 9e9 -- 1 / (4 * pi * epsilon0) 128 | integrand r' = sigma r' *^ d ^/ magnitude d ** 3 129 | where 130 | d = displacement r' r 131 | 132 | -- | Electric field produced by a volume charge. 133 | -- The function 'eField' calls this function 134 | -- to evaluate the electric field produced by a volume charge. 135 | eFieldFromVolumeCharge 136 | :: ScalarField -- ^ volume charge density rho 137 | -> Volume -- ^ geometry of the volume charge 138 | -> VectorField -- ^ electric field (in V/m) 139 | eFieldFromVolumeCharge rho v r 140 | = k *^ volumeIntegral 50 50 50 integrand v 141 | where 142 | k = 9e9 -- 1 / (4 * pi * epsilon0) 143 | integrand r' = rho r' *^ d ^/ magnitude d ** 3 144 | where 145 | d = displacement r' r 146 | 147 | -- | The electric field produced by a charge distribution. 148 | -- This is the simplest way to find the electric field, because it 149 | -- works for any charge distribution (point, line, surface, volume, or combination). 150 | eField :: ChargeDistribution -> VectorField 151 | eField (PointCharge q r') = eFieldFromPointCharge q r' 152 | eField (LineCharge lam c) = eFieldFromLineCharge lam c 153 | eField (SurfaceCharge sig s) = eFieldFromSurfaceCharge sig s 154 | eField (VolumeCharge rho v) = eFieldFromVolumeCharge rho v 155 | eField (MultipleCharges cds) = addFields $ map eField cds 156 | 157 | ------------------- 158 | -- Electric Flux -- 159 | ------------------- 160 | 161 | -- | The electric flux through a surface produced by a charge distribution. 162 | electricFlux :: Surface -> ChargeDistribution -> Double 163 | electricFlux surf dist = dottedSurfaceIntegral 200 200 (eField dist) surf 164 | 165 | ------------------------ 166 | -- Electric Potential -- 167 | ------------------------ 168 | 169 | -- | Electric potential from electric field, given a position to be the zero 170 | -- of electric potential. 171 | electricPotentialFromField :: Position -- ^ position where electric potential is zero 172 | -> VectorField -- ^ electric field 173 | -> ScalarField -- ^ electric potential 174 | electricPotentialFromField base ef r = -dottedLineIntegral 1000 ef (straightLine base r) 175 | 176 | -- | Electric potential produced by a charge distribution. 177 | -- The position where the electric potential is zero is taken to be infinity. 178 | electricPotentialFromCharge :: ChargeDistribution -> ScalarField 179 | electricPotentialFromCharge (PointCharge q r') = ePotFromPointCharge q r' 180 | electricPotentialFromCharge (LineCharge lam c) = ePotFromLineCharge lam c 181 | electricPotentialFromCharge (SurfaceCharge sig s) = ePotFromSurfaceCharge sig s 182 | electricPotentialFromCharge (VolumeCharge rho v) = ePotFromVolumeCharge rho v 183 | electricPotentialFromCharge (MultipleCharges cds) = addFields $ map electricPotentialFromCharge cds 184 | 185 | ePotFromPointCharge 186 | :: Charge -- ^ charge (in Coulombs) 187 | -> Position -- ^ of point charge 188 | -> ScalarField -- ^ electric potential 189 | ePotFromPointCharge q r' r 190 | = (k * q) / magnitude d 191 | where 192 | k = 9e9 -- 1 / (4 * pi * epsilon0) 193 | d = displacement r' r 194 | 195 | ePotFromLineCharge 196 | :: ScalarField -- ^ linear charge density lambda 197 | -> Curve -- ^ geometry of the line charge 198 | -> ScalarField -- ^ electric potential 199 | ePotFromLineCharge lambda c r 200 | = k *^ simpleLineIntegral 1000 integrand c 201 | where 202 | k = 9e9 -- 1 / (4 * pi * epsilon0) 203 | integrand r' = lambda r' / magnitude d 204 | where 205 | d = displacement r' r 206 | 207 | ePotFromSurfaceCharge 208 | :: ScalarField -- ^ surface charge density sigma 209 | -> Surface -- ^ geometry of the surface charge 210 | -> ScalarField -- ^ electric potential 211 | ePotFromSurfaceCharge sigma s r 212 | = k *^ surfaceIntegral 200 200 integrand s 213 | where 214 | k = 9e9 -- 1 / (4 * pi * epsilon0) 215 | integrand r' = sigma r' / magnitude d 216 | where 217 | d = displacement r' r 218 | 219 | ePotFromVolumeCharge 220 | :: ScalarField -- ^ volume charge density rho 221 | -> Volume -- ^ geometry of the volume charge 222 | -> ScalarField -- ^ electric potential 223 | ePotFromVolumeCharge rho v r 224 | = k *^ volumeIntegral 50 50 50 integrand v 225 | where 226 | k = 9e9 -- 1 / (4 * pi * epsilon0) 227 | integrand r' = rho r' / magnitude d 228 | where 229 | d = displacement r' r 230 | 231 | {- 232 | Student Exercise: Write a function for electric potential difference. 233 | 234 | -- | The electric potential difference V(end) - V(beginning) between the endpoints 235 | -- of a curve. 236 | electricPotentialDifference :: Curve -> ChargeDistribution -> Double 237 | electricPotentialDifference c dist = -dottedLineIntegral 1000 (eField dist) c 238 | -} 239 | 240 | --------------------------------- 241 | -- Common Charge Distributions -- 242 | --------------------------------- 243 | 244 | -------------------------------------------------------------------------------- /src/Physics/Learn/CommonVec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE Safe #-} 3 | 4 | {- | 5 | Module : Physics.Learn.CommonVec 6 | Copyright : (c) Scott N. Walck 2012-2019 7 | License : BSD3 (see LICENSE) 8 | Maintainer : Scott N. Walck 9 | Stability : experimental 10 | 11 | This module defines some common vector operations. 12 | It is intended that this module not be imported directly, but that its 13 | functionality be gained by importing either 'SimpleVec' or 'CarrotVec', 14 | but not both. Choose 'SimpleVec' for vector operations 15 | (such as vector addition) with simple concrete types, 16 | which work only with the type 'Vec' of three-dimensional vectors. 17 | Choose 'CarrotVec' for vector operations that work with any type in the 18 | appropriate type class. 19 | -} 20 | 21 | -- The definitions that are common to SimpleVec and CarrotVec. 22 | -- We need to export the data constructor Vec for both SimpleVec and CarrotVec. 23 | 24 | module Physics.Learn.CommonVec 25 | ( Vec(..) 26 | , R 27 | , vec 28 | , (><) 29 | , iHat 30 | , jHat 31 | , kHat 32 | ) 33 | where 34 | 35 | infixl 7 >< 36 | 37 | type R = Double 38 | 39 | -- | A type for vectors. 40 | data Vec = Vec { xComp :: R -- ^ x component 41 | , yComp :: R -- ^ y component 42 | , zComp :: R -- ^ z component 43 | } deriving (Eq) 44 | 45 | instance Show Vec where 46 | show (Vec x y z) = "vec " ++ showDouble x ++ " " 47 | ++ showDouble y ++ " " 48 | ++ showDouble z 49 | 50 | showDouble :: Double -> String 51 | showDouble x 52 | | x < 0 = "(" ++ show x ++ ")" 53 | | otherwise = show x 54 | 55 | -- | Form a vector by giving its x, y, and z components. 56 | vec :: R -- ^ x component 57 | -> R -- ^ y component 58 | -> R -- ^ z component 59 | -> Vec 60 | vec = Vec 61 | 62 | -- | Cross product. 63 | (><) :: Vec -> Vec -> Vec 64 | Vec ax ay az >< Vec bx by bz = Vec (ay*bz - az*by) (az*bx - ax*bz) (ax*by - ay*bx) 65 | 66 | iHat, jHat, kHat :: Vec 67 | -- | Unit vector in the x direction. 68 | iHat = vec 1 0 0 69 | -- | Unit vector in the y direction. 70 | jHat = vec 0 1 0 71 | -- | Unit vector in the z direction. 72 | kHat = vec 0 0 1 73 | -------------------------------------------------------------------------------- /src/Physics/Learn/CompositeQuadrature.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE Safe #-} 4 | 5 | {- | 6 | Module : Physics.Learn.CompositeQuadrature 7 | Copyright : (c) Scott N. Walck 2012-2018 8 | License : BSD3 (see LICENSE) 9 | Maintainer : Scott N. Walck 10 | Stability : experimental 11 | 12 | Composite Trapezoid Rule and Composite Simpson's Rule 13 | -} 14 | 15 | module Physics.Learn.CompositeQuadrature 16 | ( compositeTrapezoid 17 | , compositeSimpson 18 | ) 19 | where 20 | 21 | import Data.VectorSpace 22 | ( VectorSpace 23 | , Scalar 24 | , (^+^) 25 | , (*^) 26 | , zeroV 27 | ) 28 | 29 | -- | Composite Trapezoid Rule 30 | compositeTrapezoid :: (VectorSpace v, Fractional (Scalar v)) => 31 | Int -- ^ number of intervals (one less than the number of function evaluations) 32 | -> Scalar v -- ^ lower limit 33 | -> Scalar v -- ^ upper limit 34 | -> (Scalar v -> v) -- ^ function to be integrated 35 | -> v -- ^ definite integral 36 | compositeTrapezoid n a b f 37 | = let dt = (b - a) / fromIntegral n 38 | ts = [a + fromIntegral m * dt | m <- [0..n]] 39 | pairs = [(t,f t) | t <- ts] 40 | combine [] = error "compositeSimpson: odd number of half-intervals" -- this should never happen 41 | combine [_] = zeroV 42 | combine ((t0,f0):(t1,f1):ps) = ((t1 - t0) / 2) *^ (f0 ^+^ f1) ^+^ combine ((t1,f1):ps) 43 | in combine pairs 44 | 45 | -- | Composite Simpson's Rule 46 | compositeSimpson :: (VectorSpace v, Fractional (Scalar v)) => 47 | Int -- ^ number of half-intervals (one less than the number of function evaluations) 48 | -> Scalar v -- ^ lower limit 49 | -> Scalar v -- ^ upper limit 50 | -> (Scalar v -> v) -- ^ function to be integrated 51 | -> v -- ^ definite integral 52 | compositeSimpson n a b f 53 | = let nEven = 2 * div n 2 54 | dt = (b - a) / fromIntegral nEven 55 | ts = [a + fromIntegral m * dt | m <- [0..nEven]] 56 | pairs = [(t,f t) | t <- ts] 57 | combine [] = error "compositeSimpson: odd number of half-intervals" -- this should never happen 58 | combine [_] = zeroV 59 | combine (_:_:[]) = error "compositeSimpson: odd number of half-intervals" -- this should never happen 60 | combine ((t0,f0):(_,f1):(t2,f2):ps) = ((t2 - t0) / 6) *^ (f0 ^+^ 4 *^ f1 ^+^ f2) ^+^ combine ((t2,f2):ps) 61 | in combine pairs 62 | -------------------------------------------------------------------------------- /src/Physics/Learn/CoordinateFields.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE Safe #-} 3 | 4 | {- | 5 | Module : Physics.Learn.CoordinateFields 6 | Copyright : (c) Scott N. Walck 2012-2018 7 | License : BSD3 (see LICENSE) 8 | Maintainer : Scott N. Walck 9 | Stability : experimental 10 | 11 | Coordinate fields for Cartesian, cylindrical, and spherical coordinates. 12 | -} 13 | 14 | module Physics.Learn.CoordinateFields 15 | ( x 16 | , y 17 | , z 18 | , s 19 | , phi 20 | , r 21 | , theta 22 | ) 23 | where 24 | 25 | import Physics.Learn.Position 26 | ( ScalarField 27 | , cartesianCoordinates 28 | , cylindricalCoordinates 29 | , sphericalCoordinates 30 | ) 31 | 32 | fst3 :: (a,b,c) -> a 33 | fst3 (v,_,_) = v 34 | 35 | snd3 :: (a,b,c) -> b 36 | snd3 (_,v,_) = v 37 | 38 | thd3 :: (a,b,c) -> c 39 | thd3 (_,_,v) = v 40 | 41 | -- | The x Cartesian coordinate of a position. 42 | x :: ScalarField 43 | x = fst3 . cartesianCoordinates 44 | 45 | -- | The y Cartesian coordinate of a position. 46 | y :: ScalarField 47 | y = snd3 . cartesianCoordinates 48 | 49 | -- | The z Cartesian (or cylindrical) coordinate of a position. 50 | z :: ScalarField 51 | z = thd3 . cartesianCoordinates 52 | 53 | -- | The s cylindrical coordinate of a position. 54 | -- This is the distance of the position from the z axis. 55 | s :: ScalarField 56 | s = fst3 . cylindricalCoordinates 57 | 58 | -- | The phi cylindrical (or spherical) coordinate of a position. 59 | -- This is the angle from the positive x axis 60 | -- to the projection of the position onto the xy plane. 61 | phi :: ScalarField 62 | phi = snd3 . cylindricalCoordinates 63 | 64 | -- | The r spherical coordinate of a position. 65 | -- This is the distance of the position from the origin. 66 | r :: ScalarField 67 | r = fst3 . sphericalCoordinates 68 | 69 | -- | The theta spherical coordinate of a position. 70 | -- This is the angle from the positive z axis to the position. 71 | theta :: ScalarField 72 | theta = snd3 . sphericalCoordinates 73 | 74 | -------------------------------------------------------------------------------- /src/Physics/Learn/CoordinateSystem.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE Safe #-} 3 | 4 | {- | 5 | Module : Physics.Learn.CoordinateSystem 6 | Copyright : (c) Scott N. Walck 2012-2018 7 | License : BSD3 (see LICENSE) 8 | Maintainer : Scott N. Walck 9 | Stability : experimental 10 | 11 | A module for working with coordinate systems. 12 | -} 13 | 14 | module Physics.Learn.CoordinateSystem 15 | ( CoordinateSystem(..) 16 | , standardCartesian 17 | , standardCylindrical 18 | , standardSpherical 19 | , newCoordinateSystem 20 | ) 21 | where 22 | 23 | import Physics.Learn.Position 24 | ( Position 25 | , cartesian 26 | , cartesianCoordinates 27 | , cylindrical 28 | , cylindricalCoordinates 29 | , spherical 30 | , sphericalCoordinates 31 | ) 32 | 33 | -- | Specification of a coordinate system requires 34 | -- a map from coordinates into space, and 35 | -- a map from space into coordinates. 36 | data CoordinateSystem 37 | = CoordinateSystem { toPosition :: (Double,Double,Double) -> Position -- ^ a map from coordinates into space 38 | , fromPosition :: Position -> (Double,Double,Double) -- ^ a map from space into coordinates 39 | } 40 | 41 | -- | The standard Cartesian coordinate system 42 | standardCartesian :: CoordinateSystem 43 | standardCartesian = CoordinateSystem cartesian cartesianCoordinates 44 | 45 | -- | The standard cylindrical coordinate system 46 | standardCylindrical :: CoordinateSystem 47 | standardCylindrical = CoordinateSystem cylindrical cylindricalCoordinates 48 | 49 | -- | The standard spherical coordinate system 50 | standardSpherical :: CoordinateSystem 51 | standardSpherical = CoordinateSystem spherical sphericalCoordinates 52 | 53 | -- | Define a new coordinate system in terms of an existing one. 54 | -- First parameter is a map from old coordinates to new coordinates. 55 | -- Second parameter is the inverse map from new coordinates to old coordinates. 56 | newCoordinateSystem :: ((Double,Double,Double) -> (Double,Double,Double)) -- ^ (x',y',z') = f(x,y,z) 57 | -> ((Double,Double,Double) -> (Double,Double,Double)) -- ^ (x,y,z) = g(x',y',z') 58 | -> CoordinateSystem -- ^ old coordinate system 59 | -> CoordinateSystem 60 | newCoordinateSystem f g (CoordinateSystem tp fp) 61 | = CoordinateSystem (tp . g) (f . fp) 62 | -------------------------------------------------------------------------------- /src/Physics/Learn/Current.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE Safe #-} 3 | 4 | {- | 5 | Module : Physics.Learn.Current 6 | Copyright : (c) Scott N. Walck 2012-2019 7 | License : BSD3 (see LICENSE) 8 | Maintainer : Scott N. Walck 9 | Stability : experimental 10 | 11 | This module contains functions for working with current, magnetic field, 12 | and magnetic flux. 13 | -} 14 | 15 | module Physics.Learn.Current 16 | ( 17 | -- * Current 18 | Current 19 | , CurrentDistribution(..) 20 | -- * Magnetic Field 21 | , bField 22 | , bFieldFromLineCurrent 23 | , bFieldFromSurfaceCurrent 24 | , bFieldFromVolumeCurrent 25 | -- * Magnetic Flux 26 | , magneticFlux 27 | ) 28 | where 29 | 30 | import Physics.Learn.CarrotVec 31 | ( magnitude 32 | , (*^) 33 | , (^/) 34 | , (><) 35 | ) 36 | import Physics.Learn.Position 37 | ( VectorField 38 | , displacement 39 | , addFields 40 | ) 41 | import Physics.Learn.Curve 42 | ( Curve(..) 43 | , crossedLineIntegral 44 | ) 45 | import Physics.Learn.Surface 46 | ( Surface(..) 47 | , surfaceIntegral 48 | , dottedSurfaceIntegral 49 | ) 50 | import Physics.Learn.Volume 51 | ( Volume(..) 52 | , volumeIntegral 53 | ) 54 | 55 | -- | Electric current, in units of Amperes (A) 56 | type Current = Double 57 | 58 | -- | A current distribution is a line current (current through a wire), a surface current, 59 | -- a volume current, or a combination of these. 60 | -- The 'VectorField' describes a surface current density 61 | -- or a volume current density. 62 | data CurrentDistribution = LineCurrent Current Curve -- ^ current through a wire 63 | | SurfaceCurrent VectorField Surface -- ^ 'VectorField' is surface current density (A/m) 64 | | VolumeCurrent VectorField Volume -- ^ 'VectorField' is volume current density (A/m^2) 65 | | MultipleCurrents [CurrentDistribution] -- ^ combination of current distributions 66 | 67 | -- | Magnetic field produced by a line current (current through a wire). 68 | -- The function 'bField' calls this function 69 | -- to evaluate the magnetic field produced by a line current. 70 | bFieldFromLineCurrent 71 | :: Current -- ^ current (in Amps) 72 | -> Curve -- ^ geometry of the line current 73 | -> VectorField -- ^ magnetic field (in Tesla) 74 | bFieldFromLineCurrent i c r 75 | = k *^ crossedLineIntegral 1000 integrand c 76 | where 77 | k = 1e-7 -- mu0 / (4 * pi) 78 | integrand r' = (-i) *^ d ^/ magnitude d ** 3 79 | where 80 | d = displacement r' r 81 | 82 | -- | Magnetic field produced by a surface current. 83 | -- The function 'bField' calls this function 84 | -- to evaluate the magnetic field produced by a surface current. 85 | -- This function assumes that surface current density 86 | -- will be specified parallel to the surface, and does 87 | -- not check if that is true. 88 | bFieldFromSurfaceCurrent 89 | :: VectorField -- ^ surface current density 90 | -> Surface -- ^ geometry of the surface current 91 | -> VectorField -- ^ magnetic field (in T) 92 | bFieldFromSurfaceCurrent kCurrent c r 93 | = k *^ surfaceIntegral 100 100 integrand c 94 | where 95 | k = 1e-7 -- mu0 / (4 * pi) 96 | integrand r' = (kCurrent r' >< d) ^/ magnitude d ** 3 97 | where 98 | d = displacement r' r 99 | 100 | -- | Magnetic field produced by a volume current. 101 | -- The function 'bField' calls this function 102 | -- to evaluate the magnetic field produced by a volume current. 103 | bFieldFromVolumeCurrent 104 | :: VectorField -- ^ volume current density 105 | -> Volume -- ^ geometry of the volume current 106 | -> VectorField -- ^ magnetic field (in T) 107 | bFieldFromVolumeCurrent j c r 108 | = k *^ volumeIntegral 50 50 50 integrand c 109 | where 110 | k = 1e-7 -- mu0 / (4 * pi) 111 | integrand r' = (j r' >< d) ^/ magnitude d ** 3 112 | where 113 | d = displacement r' r 114 | 115 | -- | The magnetic field produced by a current distribution. 116 | -- This is the simplest way to find the magnetic field, because it 117 | -- works for any current distribution (line, surface, volume, or combination). 118 | bField :: CurrentDistribution -> VectorField 119 | bField (LineCurrent i c) = bFieldFromLineCurrent i c 120 | bField (SurfaceCurrent kC s) = bFieldFromSurfaceCurrent kC s 121 | bField (VolumeCurrent j v) = bFieldFromVolumeCurrent j v 122 | bField (MultipleCurrents cds) = addFields $ map bField cds 123 | 124 | ------------------- 125 | -- Magnetic Flux -- 126 | ------------------- 127 | 128 | -- | The magnetic flux through a surface produced by a current distribution. 129 | magneticFlux :: Surface -> CurrentDistribution -> Double 130 | magneticFlux surf dist = dottedSurfaceIntegral 100 100 (bField dist) surf 131 | 132 | -------------------------------------------------------------------------------- /src/Physics/Learn/Curve.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, FlexibleContexts #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | {-# LANGUAGE Safe #-} 4 | 5 | {- | 6 | Module : Physics.Learn.Curve 7 | Copyright : (c) Scott N. Walck 2012-2018 8 | License : BSD3 (see LICENSE) 9 | Maintainer : Scott N. Walck 10 | Stability : experimental 11 | 12 | This module contains functions for working with 'Curve's 13 | and line integrals along 'Curve's. 14 | -} 15 | 16 | module Physics.Learn.Curve 17 | ( 18 | -- * Curves 19 | Curve(..) 20 | , normalizeCurve 21 | , concatCurves 22 | , concatenateCurves 23 | , reverseCurve 24 | , evalCurve 25 | , shiftCurve 26 | , straightLine 27 | -- * Line Integrals 28 | , simpleLineIntegral 29 | , dottedLineIntegral 30 | , crossedLineIntegral 31 | , compositeTrapezoidDottedLineIntegral 32 | , compositeTrapezoidCrossedLineIntegral 33 | , compositeSimpsonDottedLineIntegral 34 | , compositeSimpsonCrossedLineIntegral 35 | ) 36 | where 37 | 38 | import Data.VectorSpace 39 | ( VectorSpace 40 | , InnerSpace 41 | , Scalar 42 | ) 43 | import Physics.Learn.CarrotVec 44 | ( Vec 45 | , (><) 46 | , (<.>) 47 | , sumV 48 | , (^*) 49 | , (^/) 50 | , (^+^) 51 | , (^-^) 52 | , (*^) 53 | , magnitude 54 | , zeroV 55 | , negateV 56 | ) 57 | import Physics.Learn.Position 58 | ( Position 59 | , Displacement 60 | , displacement 61 | , Field 62 | , VectorField 63 | , shiftPosition 64 | ) 65 | 66 | -- | 'Curve' is a parametrized function into three-space, an initial limit, and a final limit. 67 | data Curve = Curve { curveFunc :: Double -> Position -- ^ function from one parameter into space 68 | , startingCurveParam :: Double -- ^ starting value of the parameter 69 | , endingCurveParam :: Double -- ^ ending value of the parameter 70 | } 71 | 72 | -- | A dotted line integral. 73 | -- Convenience function for 'compositeSimpsonDottedLineIntegral'. 74 | dottedLineIntegral 75 | :: Int -- ^ number of half-intervals 76 | -- (one less than the number of function evaluations) 77 | -> VectorField -- ^ vector field 78 | -> Curve -- ^ curve to integrate over 79 | -> Double -- ^ scalar result 80 | dottedLineIntegral = compositeSimpsonDottedLineIntegral 81 | 82 | -- | Calculates integral vf x dl over curve. 83 | -- Convenience function for 'compositeSimpsonCrossedLineIntegral'. 84 | crossedLineIntegral 85 | :: Int -- ^ number of half-intervals 86 | -- (one less than the number of function evaluations) 87 | -> VectorField -- ^ vector field 88 | -> Curve -- ^ curve to integrate over 89 | -> Vec -- ^ vector result 90 | crossedLineIntegral = compositeSimpsonCrossedLineIntegral 91 | 92 | -- | A dotted line integral, performed in an unsophisticated way. 93 | compositeTrapezoidDottedLineIntegral 94 | :: Int -- ^ number of intervals 95 | -> VectorField -- ^ vector field 96 | -> Curve -- ^ curve to integrate over 97 | -> Double -- ^ scalar result 98 | compositeTrapezoidDottedLineIntegral n vf (Curve f a b) 99 | = sum $ zipWith (<.>) aveVecs dls 100 | where 101 | dt = (b - a) / fromIntegral n 102 | pts = [f t | t <- [a,a+dt..b]] 103 | vecs = [vf pt | pt <- pts] 104 | aveVecs = zipWith average vecs (tail vecs) 105 | dls = zipWith displacement pts (tail pts) 106 | 107 | -- | Calculates integral vf x dl over curve in an unsophisticated way. 108 | compositeTrapezoidCrossedLineIntegral 109 | :: Int -- ^ number of intervals 110 | -> VectorField -- ^ vector field 111 | -> Curve -- ^ curve to integrate over 112 | -> Vec -- ^ vector result 113 | compositeTrapezoidCrossedLineIntegral n vf (Curve f a b) 114 | = sumV $ zipWith (><) aveVecs dls 115 | where 116 | dt = (b - a) / fromIntegral n 117 | pts = [f t | t <- [a,a+dt..b]] 118 | vecs = [vf pt | pt <- pts] 119 | aveVecs = zipWith average vecs (tail vecs) 120 | dls = zipWith displacement pts (tail pts) 121 | 122 | -- | Calculates integral f dl over curve, where dl is a scalar line element. 123 | simpleLineIntegral 124 | :: (InnerSpace v, Scalar v ~ Double) 125 | => Int -- ^ number of intervals 126 | -> Field v -- ^ scalar or vector field 127 | -> Curve -- ^ curve to integrate over 128 | -> v -- ^ scalar or vector result 129 | simpleLineIntegral n vf (Curve f a b) 130 | = sumV $ zipWith (^*) aveVecs (map magnitude dls) 131 | where 132 | dt = (b - a) / fromIntegral n 133 | pts = [f t | t <- [a,a+dt..b]] 134 | vecs = [vf pt | pt <- pts] 135 | aveVecs = zipWith average vecs (tail vecs) 136 | dls = zipWith displacement pts (tail pts) 137 | 138 | -- | Reparametrize a curve from 0 to 1. 139 | normalizeCurve :: Curve -> Curve 140 | normalizeCurve (Curve f a b) 141 | = Curve (f . scl) 0 1 142 | where 143 | scl t = a + (b - a) * t 144 | 145 | -- | Concatenate two curves. 146 | concatCurves :: Curve -- ^ go first along this curve 147 | -> Curve -- ^ then along this curve 148 | -> Curve -- ^ to produce this new curve 149 | concatCurves c1 c2 150 | = normalizeCurve $ Curve f 0 2 151 | where 152 | (Curve f1 _ _) = normalizeCurve c1 153 | (Curve f2 _ _) = normalizeCurve c2 154 | f t | t <= 1 = f1 t 155 | | otherwise = f2 (t-1) 156 | 157 | -- | Concatenate a list of curves. 158 | -- Parametrizes curves equally. 159 | concatenateCurves :: [Curve] -> Curve 160 | concatenateCurves [] = error "concatenateCurves: cannot concatenate empty list" 161 | concatenateCurves cs = normalizeCurve $ Curve f 0 (fromIntegral n) 162 | where 163 | n = length cs 164 | ncs = map normalizeCurve cs 165 | f t = evalCurve (ncs !! m) (t - fromIntegral m) 166 | where m = min (n-1) (floor t) 167 | 168 | -- | Reverse a curve. 169 | reverseCurve :: Curve -> Curve 170 | reverseCurve (Curve f a b) 171 | = Curve (f . rev) a b 172 | where 173 | rev t = a + b - t 174 | 175 | -- | Evaluate the position of a curve at a parameter. 176 | evalCurve :: Curve -- ^ the curve 177 | -> Double -- ^ the parameter 178 | -> Position -- ^ position of the point on the curve at that parameter 179 | evalCurve (Curve f _ _) t = f t 180 | 181 | -- | Shift a curve by a displacement. 182 | shiftCurve :: Displacement -- ^ amount to shift 183 | -> Curve -- ^ original curve 184 | -> Curve -- ^ shifted curve 185 | shiftCurve d (Curve f sl su) 186 | = Curve (shiftPosition d . f) sl su 187 | 188 | -- | The straight-line curve from one position to another. 189 | straightLine :: Position -- ^ starting position 190 | -> Position -- ^ ending position 191 | -> Curve -- ^ straight-line curve 192 | straightLine r1 r2 = Curve f 0 1 193 | where 194 | f t = shiftPosition (t *^ d) r1 195 | d = displacement r1 r2 196 | 197 | ------------- 198 | -- Helpers -- 199 | ------------- 200 | 201 | average :: (VectorSpace v, Scalar v ~ Double) => v -> v -> v 202 | average v1 v2 = (v1 ^+^ v2) ^/ 2 203 | 204 | ---------------------------------------- 205 | -- Quadratic (Simpson) Approximations -- 206 | ---------------------------------------- 207 | 208 | dottedSimp :: (InnerSpace v, Fractional (Scalar v)) => 209 | v -- ^ vector field low 210 | -> v -- ^ vector field mid 211 | -> v -- ^ vector field high 212 | -> v -- ^ dl low to mid 213 | -> v -- ^ dl mid to high 214 | -> Scalar v -- ^ quadratic approximation 215 | dottedSimp f0 f1 f2 g10 g21 216 | = ((g21 ^+^ g10) ^/ 6) <.> (f0 ^+^ 4 *^ f1 ^+^ f2) 217 | + ((g21 ^-^ g10) ^/ 3) <.> (f2 ^-^ f0) 218 | 219 | -- | Quadratic approximation to vector field. 220 | -- Quadratic approximation to curve. 221 | -- Composite strategy. 222 | -- Dotted line integral. 223 | compositeSimpsonDottedLineIntegral 224 | :: Int -- ^ number of half-intervals 225 | -- (one less than the number of function evaluations) 226 | -> VectorField -- ^ vector field 227 | -> Curve -- ^ curve to integrate over 228 | -> Double -- ^ scalar result 229 | compositeSimpsonDottedLineIntegral n vf (Curve c a b) 230 | = let nEven = 2 * div n 2 231 | dt = (b - a) / fromIntegral nEven 232 | ts = [a + fromIntegral m * dt | m <- [0..nEven]] 233 | pairs = [(ct,vf ct) | t <- ts, let ct = c t] 234 | combine [] = error "compositeSimpson: odd number of half-intervals" -- this should never happen 235 | combine [_] = zeroV 236 | combine (_:_:[]) = error "compositeSimpson: odd number of half-intervals" -- this should never happen 237 | combine ((c0,f0):(c1,f1):(c2,f2):ps) 238 | = dottedSimp f0 f1 f2 (displacement c0 c1) (displacement c1 c2) 239 | ^+^ combine ((c2,f2):ps) 240 | in combine pairs 241 | 242 | crossedSimp :: Vec -- ^ vector field low 243 | -> Vec -- ^ vector field mid 244 | -> Vec -- ^ vector field high 245 | -> Vec -- ^ dl low to mid 246 | -> Vec -- ^ dl mid to high 247 | -> Vec -- ^ quadratic approximation 248 | crossedSimp f0 f1 f2 g10 g21 249 | = negateV $ 250 | ((g21 ^+^ g10) ^/ 6) >< (f0 ^+^ 4 *^ f1 ^+^ f2) 251 | ^+^ ((g21 ^-^ g10) ^/ 3) >< (f2 ^-^ f0) 252 | 253 | -- | Quadratic approximation to vector field. 254 | -- Quadratic approximation to curve. 255 | -- Composite strategy. 256 | -- Crossed line integral. 257 | compositeSimpsonCrossedLineIntegral 258 | :: Int -- ^ number of half-intervals 259 | -- (one less than the number of function evaluations) 260 | -> VectorField -- ^ vector field 261 | -> Curve -- ^ curve to integrate over 262 | -> Vec -- ^ vector result 263 | compositeSimpsonCrossedLineIntegral n vf (Curve c a b) 264 | = let nEven = 2 * div n 2 265 | dt = (b - a) / fromIntegral nEven 266 | ts = [a + fromIntegral m * dt | m <- [0..nEven]] 267 | pairs = [(ct,vf ct) | t <- ts, let ct = c t] 268 | combine [] = error "compositeSimpson: odd number of half-intervals" -- this should never happen 269 | combine [_] = zeroV 270 | combine (_:_:[]) = error "compositeSimpson: odd number of half-intervals" -- this should never happen 271 | combine ((c0,f0):(c1,f1):(c2,f2):ps) 272 | = crossedSimp f0 f1 f2 (displacement c0 c1) (displacement c1 c2) 273 | ^+^ combine ((c2,f2):ps) 274 | in combine pairs 275 | 276 | -------------------------------------------------------------------------------- /src/Physics/Learn/Ket.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE Safe #-} 3 | {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} 4 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 5 | {-# LANGUAGE CPP #-} 6 | 7 | {- | 8 | Module : Physics.Learn.Ket 9 | Copyright : (c) Scott N. Walck 2016-2018 10 | License : BSD3 (see LICENSE) 11 | Maintainer : Scott N. Walck 12 | Stability : experimental 13 | 14 | This module contains ket vectors, bra vectors, 15 | and operators for quantum mechanics. 16 | -} 17 | 18 | -- a Ket layer on top of QuantumMat 19 | 20 | module Physics.Learn.Ket 21 | ( 22 | -- * Basic data types 23 | C 24 | , i 25 | , magnitude 26 | , Ket 27 | , Bra 28 | , Operator 29 | -- * Kets for spin-1/2 particles 30 | , xp 31 | , xm 32 | , yp 33 | , ym 34 | , zp 35 | , zm 36 | , np 37 | , nm 38 | -- * Operators for spin-1/2 particles 39 | , sx 40 | , sy 41 | , sz 42 | , sn 43 | , sn' 44 | -- * Quantum Dynamics 45 | , timeEvOp 46 | , timeEv 47 | -- * Composition 48 | , Kron(..) 49 | -- * Measurement 50 | , possibleOutcomes 51 | , outcomesProjectors 52 | , outcomesProbabilities 53 | -- , prob 54 | -- , probs 55 | -- * Generic multiplication 56 | , Mult(..) 57 | -- * Adjoint operation 58 | , Dagger(..) 59 | -- * Normalization 60 | , HasNorm(..) 61 | -- * Representation 62 | , Representable(..) 63 | -- * Orthonormal bases 64 | , OrthonormalBasis 65 | , makeOB 66 | , listBasis 67 | , size 68 | -- * Orthonormal bases for spin-1/2 particles 69 | , xBasis 70 | , yBasis 71 | , zBasis 72 | , nBasis 73 | -- , angularMomentumXMatrix 74 | -- , angularMomentumYMatrix 75 | -- , angularMomentumZMatrix 76 | -- , angularMomentumPlusMatrix 77 | -- , angularMomentumMinusMatrix 78 | -- , jXMatrix 79 | -- , jYMatrix 80 | -- , jZMatrix 81 | -- , matrixCommutator 82 | -- , rotationMatrix 83 | -- , jmColumn 84 | ) 85 | where 86 | 87 | -- We try to import only from QuantumMat 88 | -- and not from Numeric.LinearAlgebra 89 | 90 | import qualified Data.Complex as C 91 | import Data.Complex 92 | ( Complex(..) 93 | , conjugate 94 | ) 95 | import qualified Physics.Learn.QuantumMat as M 96 | import Physics.Learn.QuantumMat 97 | ( C 98 | , Vector 99 | , Matrix 100 | , (#>) 101 | , (<#) 102 | , conjugateTranspose 103 | , scaleV 104 | , scaleM 105 | , conjV 106 | , fromList 107 | , toList 108 | , fromLists 109 | ) 110 | #if MIN_VERSION_base(4,11,0) 111 | import Prelude hiding ((<>)) 112 | #endif 113 | 114 | infixl 7 <> 115 | 116 | -- | A ket vector describes the state of a quantum system. 117 | data Ket = Ket (Vector C) 118 | 119 | instance Show Ket where 120 | show k = 121 | let message = "Use 'rep '." 122 | in if dim k == 2 123 | then "Representation in zBasis:\n" ++ 124 | show (rep zBasis k) ++ "\n" ++ message 125 | else message 126 | 127 | -- | An operator describes an observable (a Hermitian operator) 128 | -- or an action (a unitary operator). 129 | data Operator = Operator (Matrix C) 130 | 131 | instance Show Operator where 132 | show op = 133 | let message = "Use 'rep '." 134 | in if dim op == 2 135 | then "Representation in zBasis:\n" ++ 136 | show (rep zBasis op) ++ "\n" ++ message 137 | else message 138 | 139 | -- | A bra vector describes the state of a quantum system. 140 | data Bra = Bra (Vector C) 141 | 142 | instance Show Bra where 143 | show _ = "\nTry 'rep zBasis '" 144 | 145 | magnitude :: C -> Double 146 | magnitude = C.magnitude 147 | 148 | i :: C 149 | i = 0 :+ 1 150 | 151 | -- | Generic multiplication including inner product, 152 | -- outer product, operator product, and whatever else makes sense. 153 | -- No conjugation takes place in this operation. 154 | class Mult a b c | a b -> c where 155 | (<>) :: a -> b -> c 156 | 157 | instance Mult C C C where 158 | z1 <> z2 = z1 * z2 159 | 160 | instance Mult C Ket Ket where 161 | c <> Ket matrixKet = Ket (scaleV c matrixKet) 162 | 163 | instance Mult C Bra Bra where 164 | c <> Bra matrixBra = Bra (scaleV c matrixBra) 165 | 166 | instance Mult C Operator Operator where 167 | c <> Operator m = Operator (scaleM c m) 168 | 169 | instance Mult Ket C Ket where 170 | Ket matrixKet <> c = Ket (scaleV c matrixKet) 171 | 172 | instance Mult Bra C Bra where 173 | Bra matrixBra <> c = Bra (scaleV c matrixBra) 174 | 175 | instance Mult Operator C Operator where 176 | Operator m <> c = Operator (scaleM c m) 177 | 178 | instance Mult Bra Ket C where 179 | Bra matrixBra <> Ket matrixKet 180 | = sum $ zipWith (*) (toList matrixBra) (toList matrixKet) 181 | 182 | instance Mult Bra Operator Bra where 183 | Bra matrixBra <> Operator matrixOp 184 | = Bra (matrixBra <# matrixOp) 185 | 186 | instance Mult Operator Ket Ket where 187 | Operator matrixOp <> Ket matrixKet 188 | = Ket (matrixOp #> matrixKet) 189 | 190 | instance Mult Ket Bra Operator where 191 | Ket k <> Bra b = 192 | Operator 193 | (fromLists [[ x*y | y <- toList b] | x <- toList k]) 194 | 195 | instance Mult Operator Operator Operator where 196 | Operator m1 <> Operator m2 = Operator (m1 M.<> m2) 197 | 198 | instance Num Ket where 199 | Ket v1 + Ket v2 = Ket (v1 + v2) 200 | Ket v1 - Ket v2 = Ket (v1 - v2) 201 | (*) = error "Multiplication is not defined for kets" 202 | negate (Ket v) = Ket (negate v) 203 | abs = error "abs is not defined for kets" 204 | signum = error "signum is not defined for kets" 205 | fromInteger = error "fromInteger is not defined for kets" 206 | 207 | instance Num Bra where 208 | Bra v1 + Bra v2 = Bra (v1 + v2) 209 | Bra v1 - Bra v2 = Bra (v1 - v2) 210 | (*) = error "Multiplication is not defined for bra vectors" 211 | negate (Bra v) = Bra (negate v) 212 | abs = error "abs is not defined for bra vectors" 213 | signum = error "signum is not defined for bra vectors" 214 | fromInteger = error "fromInteger is not defined for bra vectors" 215 | 216 | instance Num Operator where 217 | Operator v1 + Operator v2 = Operator (v1 + v2) 218 | Operator v1 - Operator v2 = Operator (v1 - v2) 219 | Operator v1 * Operator v2 = Operator (v1 M.<> v2) 220 | negate (Operator v) = Operator (negate v) 221 | abs = error "abs is not defined for operators" 222 | signum = error "signum is not defined for operators" 223 | fromInteger = error "fromInteger is not defined for operators" 224 | 225 | -- | The adjoint operation on complex numbers, kets, 226 | -- bras, and operators. 227 | class Dagger a b | a -> b where 228 | dagger :: a -> b 229 | 230 | instance Dagger Ket Bra where 231 | dagger (Ket v) = Bra (conjV v) 232 | 233 | instance Dagger Bra Ket where 234 | dagger (Bra v) = Ket (conjV v) 235 | 236 | instance Dagger Operator Operator where 237 | dagger (Operator m) = Operator (conjugateTranspose m) 238 | 239 | instance Dagger C C where 240 | dagger c = conjugate c 241 | 242 | class HasNorm a where 243 | norm :: a -> Double 244 | normalize :: a -> a 245 | 246 | instance HasNorm Ket where 247 | norm (Ket v) = M.norm v 248 | normalize k = (1 / norm k :+ 0) <> k 249 | 250 | instance HasNorm Bra where 251 | norm (Bra v) = M.norm v 252 | normalize b = (1 / norm b :+ 0) <> b 253 | 254 | -- | An orthonormal basis of kets. 255 | newtype OrthonormalBasis = OB [Ket] 256 | deriving (Show) 257 | 258 | -- | Make an orthonormal basis from a list of linearly independent kets. 259 | makeOB :: [Ket] -> OrthonormalBasis 260 | makeOB = OB . gramSchmidt 261 | 262 | size :: OrthonormalBasis -> Int 263 | size (OB ks) = length ks 264 | 265 | listBasis :: OrthonormalBasis -> [Ket] 266 | listBasis (OB ks) = ks 267 | 268 | {- 269 | newOrthonormalBasis :: Int -> OrthonormalBasis 270 | newOrthonormalBasis = undefined 271 | -} 272 | 273 | class Representable a b | a -> b where 274 | rep :: OrthonormalBasis -> a -> b 275 | dim :: a -> Int 276 | 277 | instance Representable Ket (Vector C) where 278 | rep (OB ks) k = fromList (map (\bk -> dagger bk <> k) ks) 279 | dim (Ket v) = M.dim v 280 | 281 | instance Representable Bra (Vector C) where 282 | rep (OB ks) b = fromList (map (\bk -> b <> bk) ks) 283 | dim (Bra v) = M.dim v 284 | 285 | instance Representable Operator (Matrix C) where 286 | rep (OB ks) op = fromLists [[ dagger k1 <> op <> k2 | k2 <- ks ] | k1 <- ks ] 287 | dim (Operator m) = let (p,q) = M.size m 288 | in if p == q then p else error "dim: non-square operator" 289 | 290 | -------------- 291 | -- Spin 1/2 -- 292 | -------------- 293 | 294 | -- | State of a spin-1/2 particle if measurement 295 | -- in the x-direction would give angular momentum +hbar/2. 296 | xp :: Ket 297 | xp = Ket M.xp 298 | 299 | -- | State of a spin-1/2 particle if measurement 300 | -- in the x-direction would give angular momentum -hbar/2. 301 | xm :: Ket 302 | xm = Ket M.xm 303 | 304 | -- | State of a spin-1/2 particle if measurement 305 | -- in the y-direction would give angular momentum +hbar/2. 306 | yp :: Ket 307 | yp = Ket M.yp 308 | 309 | -- | State of a spin-1/2 particle if measurement 310 | -- in the y-direction would give angular momentum -hbar/2. 311 | ym :: Ket 312 | ym = Ket M.ym 313 | 314 | -- | State of a spin-1/2 particle if measurement 315 | -- in the z-direction would give angular momentum +hbar/2. 316 | zp :: Ket 317 | zp = Ket M.zp 318 | 319 | -- | State of a spin-1/2 particle if measurement 320 | -- in the z-direction would give angular momentum -hbar/2. 321 | zm :: Ket 322 | zm = Ket M.zm 323 | 324 | -- | State of a spin-1/2 particle if measurement 325 | -- in the n-direction, described by spherical polar angle theta 326 | -- and azimuthal angle phi, would give angular momentum +hbar/2. 327 | np :: Double -> Double -> Ket 328 | np theta phi 329 | = (cos (theta / 2) :+ 0) <> zp 330 | + (sin (theta / 2) :+ 0) * (cos phi :+ sin phi) <> zm 331 | 332 | -- | State of a spin-1/2 particle if measurement 333 | -- in the n-direction, described by spherical polar angle theta 334 | -- and azimuthal angle phi, would give angular momentum -hbar/2. 335 | nm :: Double -> Double -> Ket 336 | nm theta phi 337 | = (sin (theta / 2) :+ 0) <> zp 338 | - (cos (theta / 2) :+ 0) * (cos phi :+ sin phi) <> zm 339 | 340 | -- | The orthonormal basis composed of 'xp' and 'xm'. 341 | xBasis :: OrthonormalBasis 342 | xBasis = makeOB [xp,xm] 343 | 344 | -- | The orthonormal basis composed of 'yp' and 'ym'. 345 | yBasis :: OrthonormalBasis 346 | yBasis = makeOB [yp,ym] 347 | 348 | -- | The orthonormal basis composed of 'zp' and 'zm'. 349 | zBasis :: OrthonormalBasis 350 | zBasis = makeOB [zp,zm] 351 | 352 | -- | Given spherical polar angle theta and azimuthal angle phi, 353 | -- the orthonormal basis composed of 'np' theta phi and 'nm' theta phi. 354 | nBasis :: Double -> Double -> OrthonormalBasis 355 | nBasis theta phi = makeOB [np theta phi,nm theta phi] 356 | 357 | -- | The Pauli X operator. 358 | sx :: Operator 359 | sx = xp <> dagger xp - xm <> dagger xm 360 | 361 | -- | The Pauli Y operator. 362 | sy :: Operator 363 | sy = yp <> dagger yp - ym <> dagger ym 364 | 365 | -- | The Pauli Z operator. 366 | sz :: Operator 367 | sz = zp <> dagger zp - zm <> dagger zm 368 | 369 | -- | Pauli operator for an arbitrary direction given 370 | -- by spherical coordinates theta and phi. 371 | sn :: Double -> Double -> Operator 372 | sn theta phi 373 | = (sin theta * cos phi :+ 0) <> sx + 374 | (sin theta * sin phi :+ 0) <> sy + 375 | (cos theta :+ 0) <> sz 376 | 377 | -- | Alternative definition 378 | -- of Pauli operator for an arbitrary direction. 379 | sn' :: Double -> Double -> Operator 380 | sn' theta phi 381 | = np theta phi <> dagger (np theta phi) - 382 | nm theta phi <> dagger (nm theta phi) 383 | 384 | ---------------------- 385 | -- Quantum Dynamics -- 386 | ---------------------- 387 | 388 | -- | Given a time step and a Hamiltonian operator, 389 | -- produce a unitary time evolution operator. 390 | -- Unless you really need the time evolution operator, 391 | -- it is better to use 'timeEv', which gives the 392 | -- same numerical results without doing an explicit 393 | -- matrix inversion. The function assumes hbar = 1. 394 | timeEvOp :: Double -> Operator -> Operator 395 | timeEvOp dt (Operator m) = Operator (M.timeEvMat dt m) 396 | 397 | -- | Given a time step and a Hamiltonian operator, 398 | -- advance the state ket using the Schrodinger equation. 399 | -- This method should be faster than using 'timeEvOp' 400 | -- since it solves a linear system rather than calculating 401 | -- an inverse matrix. The function assumes hbar = 1. 402 | timeEv :: Double -> Operator -> Ket -> Ket 403 | timeEv dt (Operator m) (Ket k) = Ket $ M.timeEv dt m k 404 | 405 | ----------------- 406 | -- Composition -- 407 | ----------------- 408 | 409 | class Kron a where 410 | kron :: a -> a -> a 411 | 412 | instance Kron Ket where 413 | kron (Ket v1) (Ket v2) = Ket (M.kron v1 v2) 414 | 415 | instance Kron Bra where 416 | kron (Bra v1) (Bra v2) = Bra (M.kron v1 v2) 417 | 418 | instance Kron Operator where 419 | kron (Operator m1) (Operator m2) = Operator (M.kron m1 m2) 420 | 421 | ----------------- 422 | -- Measurement -- 423 | ----------------- 424 | 425 | -- | The possible outcomes of a measurement 426 | -- of an observable. 427 | -- These are the eigenvalues of the operator 428 | -- of the observable. 429 | possibleOutcomes :: Operator -> [Double] 430 | possibleOutcomes (Operator observable) = M.possibleOutcomes observable 431 | 432 | -- | Given an obervable, return a list of pairs 433 | -- of possible outcomes and projectors 434 | -- for each outcome. 435 | outcomesProjectors :: Operator -> [(Double,Operator)] 436 | outcomesProjectors (Operator m) 437 | = [(val,Operator p) | (val,p) <- M.outcomesProjectors m] 438 | 439 | -- | Given an observable and a state ket, return a list of pairs 440 | -- of possible outcomes and probabilites 441 | -- for each outcome. 442 | outcomesProbabilities :: Operator -> Ket -> [(Double,Double)] 443 | outcomesProbabilities (Operator m) (Ket v) 444 | = M.outcomesProbabilities m v 445 | 446 | {- 447 | prob :: Ket -> Ket -> Double 448 | prob k1 k2 = magnitude c ** 2 449 | where 450 | c = dagger k1 <> k2 451 | 452 | probs :: OrthonormalBasis -> Ket -> [Double] 453 | probs (OB ks) k = map (\bk -> let c = dagger bk <> k in magnitude c ** 2) ks 454 | -} 455 | 456 | {- 457 | ---------------------------------------- 458 | -- Angular Momentum of arbitrary size -- 459 | ---------------------------------------- 460 | 461 | angularMomentumZMatrix :: Rational -> Matrix Cyclotomic 462 | angularMomentumZMatrix j 463 | = case twoJPlusOne j of 464 | Nothing -> error "j must be a nonnegative integer or half-integer" 465 | Just d -> matrix d d (\(r,c) -> if r == c then fromRational (j + 1 - fromIntegral r) else 0) 466 | 467 | twoJPlusOne :: Rational -> Maybe Int 468 | twoJPlusOne j 469 | | j >= 0 && (denominator j == 1 || denominator j == 2) = Just $ fromIntegral $ numerator (2 * j + 1) 470 | | otherwise = Nothing 471 | 472 | angularMomentumPlusMatrix :: Rational -> Matrix Cyclotomic 473 | angularMomentumPlusMatrix j 474 | = case twoJPlusOne j of 475 | Nothing -> error "j must be a nonnegative integer or half-integer" 476 | Just d -> matrix d d (\(r,c) -> let mr = j + 1 - fromIntegral r 477 | mc = j + 1 - fromIntegral c 478 | in if mr == mc + 1 479 | then sqrtRat (j*(j+1) - mc*mr) 480 | else 0 481 | ) 482 | 483 | angularMomentumMinusMatrix :: Rational -> Matrix Cyclotomic 484 | angularMomentumMinusMatrix j 485 | = case twoJPlusOne j of 486 | Nothing -> error "j must be a nonnegative integer or half-integer" 487 | Just d -> matrix d d (\(r,c) -> let mr = j + 1 - fromIntegral r 488 | mc = j + 1 - fromIntegral c 489 | in if mr + 1 == mc 490 | then sqrtRat (j*(j+1) - mc*mr) 491 | else 0 492 | ) 493 | 494 | angularMomentumXMatrix :: Rational -> Matrix Cyclotomic 495 | angularMomentumXMatrix j 496 | = scaleMatrix (1/2) (angularMomentumPlusMatrix j + angularMomentumMinusMatrix j) 497 | 498 | angularMomentumYMatrix :: Rational -> Matrix Cyclotomic 499 | angularMomentumYMatrix j 500 | = scaleMatrix (1/(2*i)) (angularMomentumPlusMatrix j - angularMomentumMinusMatrix j) 501 | 502 | jXMatrix :: Rational -> Matrix Cyclotomic 503 | jXMatrix = angularMomentumXMatrix 504 | 505 | jYMatrix :: Rational -> Matrix Cyclotomic 506 | jYMatrix = angularMomentumYMatrix 507 | 508 | jZMatrix :: Rational -> Matrix Cyclotomic 509 | jZMatrix = angularMomentumZMatrix 510 | 511 | matrixCommutator :: Matrix Cyclotomic -> Matrix Cyclotomic -> Matrix Cyclotomic 512 | matrixCommutator m1 m2 = m1 * m2 - m2 * m1 513 | 514 | ----------------------- 515 | -- Rotation matrices -- 516 | ----------------------- 517 | 518 | r2i :: Rational -> Integer 519 | r2i r 520 | | denominator r == 1 = numerator r 521 | | otherwise = error "r2i: not an integer" 522 | 523 | -- from Sakurai, revised, (3.8.33) 524 | -- beta in degrees 525 | smallDRotElement :: Rational -> Rational -> Rational -> Rational -> Cyclotomic 526 | smallDRotElement j m' m beta 527 | = sum [parity(k-m+m') * sqrtRat (fact(j+m) * fact(j-m) * fact(j+m') * fact(j-m')) 528 | / fromRational (fact(j+m-k) * fact(k) * fact(j-k-m') * fact(k-m+m')) 529 | * cosDeg (beta/2) ^ r2i(2*j-2*k+m-m') 530 | * sinDeg (beta/2) ^ r2i(2*k-m+m') | k <- [max 0 (m-m') .. min (j+m) (j-m')]] 531 | 532 | parity :: Rational -> Cyclotomic 533 | parity = fromIntegral . parityInteger . r2i 534 | 535 | -- | (-1)^n, where n might be negative 536 | parityInteger :: Integer -> Integer 537 | parityInteger n 538 | | odd n = -1 539 | | otherwise = 1 540 | 541 | factInteger :: Integer -> Integer 542 | factInteger n 543 | | n == 0 = 1 544 | | n > 0 = n * factInteger (n-1) 545 | | otherwise = error "factInteger called on negative argument" 546 | 547 | fact :: Rational -> Rational 548 | fact = fromIntegral . factInteger . r2i 549 | 550 | -- | Rotation matrix elements. 551 | -- From Sakurai, Revised Edition, (3.5.50). 552 | -- The matrix desribes a rotation by gamma about the z axis, 553 | -- followed by a rotation by beta about the y axis, 554 | -- followed by a rotation by alpha about the z axis. 555 | bigDRotElement :: Rational -- ^ j, a nonnegative integer or half-integer 556 | -> Rational -- ^ m', an integer or half-integer index for the row 557 | -> Rational -- ^ m, an integer or half-integer index for the column 558 | -> Rational -- ^ alpha, in degrees 559 | -> Rational -- ^ beta, in degrees 560 | -> Rational -- ^ gamma, in degrees 561 | -> Cyclotomic -- ^ rotation matrix element 562 | bigDRotElement j m' m alpha beta gamma 563 | = polarRat 1 (-(m' * alpha + m * gamma) / 360) * smallDRotElement j m' m beta 564 | 565 | -- | Rotation matrix for a spin-j particle. 566 | -- The matrix desribes a rotation by gamma about the z axis, 567 | -- followed by a rotation by beta about the y axis, 568 | -- followed by a rotation by alpha about the z axis. 569 | rotationMatrix :: Rational -- ^ j, a nonnegative integer or half-integer 570 | -> Rational -- ^ alpha, in degrees 571 | -> Rational -- ^ beta, in degrees 572 | -> Rational -- ^ gamma, in degrees 573 | -> Matrix Cyclotomic -- ^ rotation matrix 574 | rotationMatrix j alpha beta gamma 575 | = case twoJPlusOne j of 576 | Nothing -> error "bigDRotMatrix: j must be a nonnegative integer or half-integer" 577 | Just d -> matrix d d (\(r,c) -> let m' = j + 1 - fromIntegral r 578 | m = j + 1 - fromIntegral c 579 | in bigDRotElement j m' m alpha beta gamma 580 | ) 581 | 582 | ---------------------------------- 583 | -- Angular Momentum eigenstates -- 584 | ---------------------------------- 585 | 586 | jmColumn :: Rational -> Rational -> Matrix Cyclotomic 587 | jmColumn j m 588 | = case twoJPlusOne j of 589 | Nothing -> error "bigDRotMatrix: j must be a nonnegative integer or half-integer" 590 | Just d -> matrix d 1 (\(r,_) -> let m' = j + 1 - fromIntegral r 591 | in if m == m' 592 | then 1 593 | else 0 594 | ) 595 | -} 596 | 597 | ------------------ 598 | -- Gram-Schmidt -- 599 | ------------------ 600 | 601 | -- | Form an orthonormal list of kets from 602 | -- a list of linearly independent kets. 603 | gramSchmidt :: [Ket] -> [Ket] 604 | gramSchmidt [] = [] 605 | gramSchmidt [k] = [normalize k] 606 | gramSchmidt (k:ks) = let nks = gramSchmidt ks 607 | nk = normalize (foldl (-) k [w <> dagger w <> k | w <- nks]) 608 | in nk:nks 609 | 610 | -- todo: Clebsch-Gordon coeffs 611 | -------------------------------------------------------------------------------- /src/Physics/Learn/Mechanics.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE Safe #-} 4 | 5 | {- | 6 | Module : Physics.Learn.Mechanics 7 | Copyright : (c) Scott N. Walck 2014-2019 8 | License : BSD3 (see LICENSE) 9 | Maintainer : Scott N. Walck 10 | Stability : experimental 11 | 12 | Newton's second law and all that 13 | -} 14 | 15 | module Physics.Learn.Mechanics 16 | ( TheTime 17 | , TimeStep 18 | , Velocity 19 | -- * Simple one-particle state 20 | , SimpleState 21 | , SimpleAccelerationFunction 22 | , simpleStateDeriv 23 | , simpleRungeKuttaStep 24 | -- * One-particle state 25 | , St(..) 26 | , DSt(..) 27 | , OneParticleSystemState 28 | , OneParticleAccelerationFunction 29 | , oneParticleStateDeriv 30 | , oneParticleRungeKuttaStep 31 | , oneParticleRungeKuttaSolution 32 | -- * Two-particle state 33 | , TwoParticleSystemState 34 | , TwoParticleAccelerationFunction 35 | , twoParticleStateDeriv 36 | , twoParticleRungeKuttaStep 37 | -- * Many-particle state 38 | , ManyParticleSystemState 39 | , ManyParticleAccelerationFunction 40 | , manyParticleStateDeriv 41 | , manyParticleRungeKuttaStep 42 | ) 43 | where 44 | 45 | import Data.VectorSpace 46 | ( AdditiveGroup(..) 47 | , VectorSpace(..) 48 | ) 49 | import Physics.Learn.StateSpace 50 | ( StateSpace(..) 51 | , Diff 52 | , DifferentialEquation 53 | ) 54 | import Physics.Learn.RungeKutta 55 | ( rungeKutta4 56 | , integrateSystem 57 | ) 58 | import Physics.Learn.Position 59 | ( Position 60 | ) 61 | import Physics.Learn.CarrotVec 62 | ( Vec 63 | ) 64 | 65 | -- | Time (in s). 66 | type TheTime = Double 67 | 68 | -- | A time step (in s). 69 | type TimeStep = Double 70 | 71 | -- | Velocity of a particle (in m/s). 72 | type Velocity = Vec 73 | 74 | ------------------------------- 75 | -- Simple one-particle state -- 76 | ------------------------------- 77 | 78 | -- | A simple one-particle state, 79 | -- to get started quickly with mechanics of one particle. 80 | type SimpleState = (TheTime,Position,Velocity) 81 | 82 | -- | An acceleration function gives the particle's acceleration as 83 | -- a function of the particle's state. 84 | -- The specification of this function is what makes one single-particle 85 | -- mechanics problem different from another. 86 | -- In order to write this function, add all of the forces 87 | -- that act on the particle, and divide this net force by the particle's mass. 88 | -- (Newton's second law). 89 | type SimpleAccelerationFunction = SimpleState -> Vec 90 | 91 | -- | Time derivative of state for a single particle 92 | -- with a constant mass. 93 | simpleStateDeriv :: SimpleAccelerationFunction -- ^ acceleration function for the particle 94 | -> DifferentialEquation SimpleState -- ^ differential equation 95 | simpleStateDeriv a (t, r, v) = (1, v, a(t, r, v)) 96 | 97 | -- | Single Runge-Kutta step 98 | simpleRungeKuttaStep :: SimpleAccelerationFunction -- ^ acceleration function for the particle 99 | -> TimeStep -- ^ time step 100 | -> SimpleState -- ^ initial state 101 | -> SimpleState -- ^ state after one time step 102 | simpleRungeKuttaStep = rungeKutta4 . simpleStateDeriv 103 | 104 | ------------------------ 105 | -- One-particle state -- 106 | ------------------------ 107 | 108 | -- | The state of a single particle is given by 109 | -- the position of the particle and the velocity of the particle. 110 | data St = St { position :: Position 111 | , velocity :: Velocity 112 | } 113 | deriving (Show) 114 | 115 | -- | The associated vector space for the 116 | -- state of a single particle. 117 | data DSt = DSt Vec Vec 118 | deriving (Show) 119 | 120 | instance AdditiveGroup DSt where 121 | zeroV = DSt zeroV zeroV 122 | negateV (DSt dr dv) = DSt (negateV dr) (negateV dv) 123 | DSt dr1 dv1 ^+^ DSt dr2 dv2 = DSt (dr1 ^+^ dr2) (dv1 ^+^ dv2) 124 | 125 | instance VectorSpace DSt where 126 | type Scalar DSt = Double 127 | c *^ DSt dr dv = DSt (c*^dr) (c*^dv) 128 | 129 | instance StateSpace St where 130 | type Diff St = DSt 131 | St r1 v1 .-. St r2 v2 = DSt (r1 .-. r2) (v1 .-. v2) 132 | St r1 v1 .+^ DSt dr dv = St (r1 .+^ dr) (v1 .+^ dv) 133 | 134 | -- | The state of a system of one particle is given by the current time, 135 | -- the position of the particle, and the velocity of the particle. 136 | -- Including time in the state like this allows us to 137 | -- have time-dependent forces. 138 | type OneParticleSystemState = (TheTime,St) 139 | 140 | -- | An acceleration function gives the particle's acceleration as 141 | -- a function of the particle's state. 142 | type OneParticleAccelerationFunction = OneParticleSystemState -> Vec 143 | 144 | -- | Time derivative of state for a single particle 145 | -- with a constant mass. 146 | oneParticleStateDeriv :: OneParticleAccelerationFunction -- ^ acceleration function for the particle 147 | -> DifferentialEquation OneParticleSystemState -- ^ differential equation 148 | oneParticleStateDeriv a st@(_t, St _r v) = (1, DSt v (a st)) 149 | 150 | -- | Single Runge-Kutta step 151 | oneParticleRungeKuttaStep :: OneParticleAccelerationFunction -- ^ acceleration function for the particle 152 | -> TimeStep -- ^ time step 153 | -> OneParticleSystemState -- ^ initial state 154 | -> OneParticleSystemState -- ^ state after one time step 155 | oneParticleRungeKuttaStep = rungeKutta4 . oneParticleStateDeriv 156 | 157 | -- | List of system states 158 | oneParticleRungeKuttaSolution :: OneParticleAccelerationFunction -- ^ acceleration function for the particle 159 | -> TimeStep -- ^ time step 160 | -> OneParticleSystemState -- ^ initial state 161 | -> [OneParticleSystemState] -- ^ state after one time step 162 | oneParticleRungeKuttaSolution = integrateSystem . oneParticleStateDeriv 163 | 164 | ------------------------ 165 | -- Two-particle state -- 166 | ------------------------ 167 | 168 | -- | The state of a system of two particles is given by the current time, 169 | -- the position and velocity of particle 1, 170 | -- and the position and velocity of particle 2. 171 | type TwoParticleSystemState = (TheTime,St,St) 172 | 173 | -- | An acceleration function gives a pair of accelerations 174 | -- (one for particle 1, one for particle 2) as 175 | -- a function of the system's state. 176 | type TwoParticleAccelerationFunction = TwoParticleSystemState -> (Vec,Vec) 177 | 178 | -- | Time derivative of state for two particles 179 | -- with constant mass. 180 | twoParticleStateDeriv :: TwoParticleAccelerationFunction -- ^ acceleration function for two particles 181 | -> DifferentialEquation TwoParticleSystemState -- ^ differential equation 182 | twoParticleStateDeriv af2 st2@(_t, St _r1 v1, St _r2 v2) = (1, DSt v1 a1, DSt v2 a2) 183 | where 184 | (a1,a2) = af2 st2 185 | 186 | -- | Single Runge-Kutta step for two-particle system 187 | twoParticleRungeKuttaStep :: TwoParticleAccelerationFunction -- ^ acceleration function 188 | -> TimeStep -- ^ time step 189 | -> TwoParticleSystemState -- ^ initial state 190 | -> TwoParticleSystemState -- ^ state after one time step 191 | twoParticleRungeKuttaStep = rungeKutta4 . twoParticleStateDeriv 192 | 193 | ------------------------- 194 | -- Many-particle state -- 195 | ------------------------- 196 | 197 | -- | The state of a system of many particles is given by the current time 198 | -- and a list of one-particle states. 199 | type ManyParticleSystemState = (TheTime,[St]) 200 | 201 | -- | An acceleration function gives a list of accelerations 202 | -- (one for each particle) as 203 | -- a function of the system's state. 204 | type ManyParticleAccelerationFunction = ManyParticleSystemState -> [Vec] 205 | 206 | -- | Time derivative of state for many particles 207 | -- with constant mass. 208 | manyParticleStateDeriv :: ManyParticleAccelerationFunction -- ^ acceleration function for many particles 209 | -> DifferentialEquation ManyParticleSystemState -- ^ differential equation 210 | manyParticleStateDeriv af st@(_t, sts) = (1, [DSt v a | (v,a) <- zip vs as]) 211 | where 212 | vs = map velocity sts 213 | as = af st 214 | 215 | -- | Single Runge-Kutta step for many-particle system 216 | manyParticleRungeKuttaStep :: ManyParticleAccelerationFunction -- ^ acceleration function 217 | -> TimeStep -- ^ time step 218 | -> ManyParticleSystemState -- ^ initial state 219 | -> ManyParticleSystemState -- ^ state after one time step 220 | manyParticleRungeKuttaStep = rungeKutta4 . manyParticleStateDeriv 221 | 222 | 223 | 224 | -- Can we automatically incorporate Newton's third law? 225 | 226 | -------------------------------------------------------------------------------- /src/Physics/Learn/Position.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE Safe #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | {-# OPTIONS_GHC -Wall #-} 5 | 6 | -- | 7 | -- Module : Physics.Learn.Position 8 | -- Copyright : (c) Scott N. Walck 2012-2018 9 | -- License : BSD3 (see LICENSE) 10 | -- Maintainer : Scott N. Walck 11 | -- Stability : experimental 12 | -- 13 | -- A module for working with the idea of position and coordinate systems. 14 | module Physics.Learn.Position 15 | ( Position 16 | , Displacement 17 | , ScalarField 18 | , VectorField 19 | , Field 20 | , CoordinateSystem 21 | , cartesian 22 | , cylindrical 23 | , spherical 24 | , cart 25 | , cyl 26 | , sph 27 | , cartesianCoordinates 28 | , cylindricalCoordinates 29 | , sphericalCoordinates 30 | , displacement 31 | , shiftPosition 32 | , shiftObject 33 | , shiftField 34 | , addFields 35 | , rHat 36 | , thetaHat 37 | , phiHat 38 | , sHat 39 | , xHat 40 | , yHat 41 | , zHat 42 | ) 43 | where 44 | 45 | import Data.VectorSpace 46 | ( AdditiveGroup 47 | ) 48 | import Physics.Learn.CarrotVec 49 | ( Vec 50 | , iHat 51 | , jHat 52 | , kHat 53 | , magnitude 54 | , sumV 55 | , vec 56 | , xComp 57 | , yComp 58 | , zComp 59 | , (^/) 60 | ) 61 | 62 | -- | A type for position. 63 | -- Position is not a vector because it makes no sense to add positions. 64 | data Position = Cart Double Double Double 65 | deriving (Show) 66 | 67 | -- | A displacement is a vector. 68 | type Displacement = Vec 69 | 70 | -- | A scalar field associates a number with each position in space. 71 | type ScalarField = Position -> Double 72 | 73 | {- 74 | -- | Scalar fields can be added, subtracted, multiplied, and negated, 75 | -- just like scalars themselves. 76 | instance Num ScalarField where 77 | (f + g) x = f x + g x 78 | (f * g) x = f x * g x 79 | (f - g) x = f x - g x 80 | negate f x = negate (f x) 81 | abs f x = abs (f x) 82 | signum f x = signum (f x) 83 | fromInteger n = const (fromInteger n) 84 | 85 | -- | Scalar fields can be divided, just like scalars themselves. 86 | instance Fractional ScalarField where 87 | (f / g) x = f x / g x 88 | recip f x = recip (f x) 89 | fromRational rat = const (fromRational rat) 90 | 91 | -- | Cosine of a scalar field, etc. 92 | instance Floating ScalarField where 93 | pi = const pi 94 | exp f x = exp (f x) 95 | sqrt f x = sqrt (f x) 96 | log f x = log (f x) 97 | (f ** g) x = f x ** g x 98 | logBase f g x = logBase (f x) (g x) 99 | sin f x = sin (f x) 100 | cos f x = cos (f x) 101 | tan f x = tan (f x) 102 | asin f x = asin (f x) 103 | acos f x = acos (f x) 104 | atan f x = atan (f x) 105 | sinh f x = sinh (f x) 106 | cosh f x = cosh (f x) 107 | tanh f x = tanh (f x) 108 | asinh f x = asinh (f x) 109 | acosh f x = acosh (f x) 110 | atanh f x = atanh (f x) 111 | -} 112 | 113 | -- | A vector field associates a vector with each position in space. 114 | type VectorField = Field Vec 115 | 116 | -- | Sometimes we want to be able to talk about a field without saying 117 | -- whether it is a scalar field or a vector field. 118 | type Field v = Position -> v 119 | 120 | -- | A coordinate system is a function from three parameters to space. 121 | type CoordinateSystem = (Double, Double, Double) -> Position 122 | 123 | -- | Add two scalar fields or two vector fields. 124 | addFields :: AdditiveGroup v => [Field v] -> Field v 125 | addFields flds r = sumV [fld r | fld <- flds] 126 | 127 | -- | The Cartesian coordinate system. Coordinates are (x,y,z). 128 | cartesian :: CoordinateSystem 129 | cartesian (x, y, z) = Cart x y z 130 | 131 | -- | The cylindrical coordinate system. Coordinates are (s,phi,z), 132 | -- where s is the distance from the z axis and phi is the angle 133 | -- with the x axis. 134 | cylindrical :: CoordinateSystem 135 | cylindrical (s, phi, z) = Cart (s * cos phi) (s * sin phi) z 136 | 137 | -- | The spherical coordinate system. Coordinates are (r,theta,phi), 138 | -- where r is the distance from the origin, theta is the angle with 139 | -- the z axis, and phi is the azimuthal angle. 140 | spherical :: CoordinateSystem 141 | spherical (r, th, phi) = Cart (r * sin th * cos phi) (r * sin th * sin phi) (r * cos th) 142 | 143 | -- | A helping function to take three numbers x, y, and z and form the 144 | -- appropriate position using Cartesian coordinates. 145 | cart 146 | :: Double 147 | -- ^ x coordinate 148 | -> Double 149 | -- ^ y coordinate 150 | -> Double 151 | -- ^ z coordinate 152 | -> Position 153 | cart = Cart 154 | 155 | -- | A helping function to take three numbers s, phi, and z and form the 156 | -- appropriate position using cylindrical coordinates. 157 | cyl 158 | :: Double 159 | -- ^ s coordinate 160 | -> Double 161 | -- ^ phi coordinate 162 | -> Double 163 | -- ^ z coordinate 164 | -> Position 165 | cyl s phi z = Cart (s * cos phi) (s * sin phi) z 166 | 167 | -- | A helping function to take three numbers r, theta, and phi and form the 168 | -- appropriate position using spherical coordinates. 169 | sph 170 | :: Double 171 | -- ^ r coordinate 172 | -> Double 173 | -- ^ theta coordinate 174 | -> Double 175 | -- ^ phi coordinate 176 | -> Position 177 | sph r theta phi = Cart (r * sin theta * cos phi) (r * sin theta * sin phi) (r * cos theta) 178 | 179 | -- | Returns the three Cartesian coordinates as a triple from a position. 180 | cartesianCoordinates :: Position -> (Double, Double, Double) 181 | cartesianCoordinates (Cart x y z) = (x, y, z) 182 | 183 | -- | Returns the three cylindrical coordinates as a triple from a position. 184 | cylindricalCoordinates :: Position -> (Double, Double, Double) 185 | cylindricalCoordinates (Cart x y z) = (s, phi, z) 186 | where 187 | s = sqrt (x ** 2 + y ** 2) 188 | phi = atan2 y x 189 | 190 | -- | Returns the three spherical coordinates as a triple from a position. 191 | sphericalCoordinates :: Position -> (Double, Double, Double) 192 | sphericalCoordinates (Cart x y z) = (r, theta, phi) 193 | where 194 | r = sqrt (x ** 2 + y ** 2 + z ** 2) 195 | theta = atan2 s z 196 | s = sqrt (x ** 2 + y ** 2) 197 | phi = atan2 y x 198 | 199 | -- | Displacement from source position to target position. 200 | displacement 201 | :: Position 202 | -- ^ source position 203 | -> Position 204 | -- ^ target position 205 | -> Displacement 206 | displacement (Cart x' y' z') (Cart x y z) = vec (x - x') (y - y') (z - z') 207 | 208 | -- | Shift a position by a displacement. 209 | shiftPosition :: Displacement -> Position -> Position 210 | shiftPosition v (Cart x y z) = Cart (x + xComp v) (y + yComp v) (z + zComp v) 211 | 212 | -- | An object is a map into 'Position'. 213 | shiftObject :: Displacement -> (a -> Position) -> (a -> Position) 214 | shiftObject d f = shiftPosition d . f 215 | 216 | -- | A field is a map from 'Position'. 217 | shiftField :: Displacement -> (Position -> v) -> (Position -> v) 218 | shiftField d f = f . shiftPosition d 219 | 220 | -- | The vector field in which each point in space is associated 221 | -- with a unit vector in the direction of increasing spherical coordinate 222 | -- r, while spherical coordinates theta and phi 223 | -- are held constant. 224 | -- Defined everywhere except at the origin. 225 | -- The unit vector 'rHat' points in different directions at different points 226 | -- in space. It is therefore better interpreted as a vector field, rather 227 | -- than a vector. 228 | rHat :: Field Vec 229 | rHat rv = d ^/ magnitude d 230 | where 231 | d = displacement (cart 0 0 0) rv 232 | 233 | -- | The vector field in which each point in space is associated 234 | -- with a unit vector in the direction of increasing spherical coordinate 235 | -- theta, while spherical coordinates r and phi are held constant. 236 | -- Defined everywhere except on the z axis. 237 | thetaHat :: Field Vec 238 | thetaHat r = vec (cos theta * cos phi) (cos theta * sin phi) (-sin theta) 239 | where 240 | (_, theta, phi) = sphericalCoordinates r 241 | 242 | -- | The vector field in which each point in space is associated 243 | -- with a unit vector in the direction of increasing (cylindrical or spherical) coordinate 244 | -- phi, while cylindrical coordinates s and z 245 | -- (or spherical coordinates r and theta) are held constant. 246 | -- Defined everywhere except on the z axis. 247 | phiHat :: Field Vec 248 | phiHat r = vec (-sin phi) (cos phi) 0 249 | where 250 | (_, phi, _) = cylindricalCoordinates r 251 | 252 | -- | The vector field in which each point in space is associated 253 | -- with a unit vector in the direction of increasing cylindrical coordinate 254 | -- s, while cylindrical coordinates phi and z 255 | -- are held constant. 256 | -- Defined everywhere except on the z axis. 257 | sHat :: Field Vec 258 | sHat r = vec (cos phi) (sin phi) 0 259 | where 260 | (_, phi, _) = cylindricalCoordinates r 261 | 262 | -- | The vector field in which each point in space is associated 263 | -- with a unit vector in the direction of increasing Cartesian coordinate 264 | -- x, while Cartesian coordinates y and z 265 | -- are held constant. 266 | -- Defined everywhere. 267 | xHat :: Field Vec 268 | xHat = const iHat 269 | 270 | -- | The vector field in which each point in space is associated 271 | -- with a unit vector in the direction of increasing Cartesian coordinate 272 | -- y, while Cartesian coordinates x and z 273 | -- are held constant. 274 | -- Defined everywhere. 275 | yHat :: Field Vec 276 | yHat = const jHat 277 | 278 | -- | The vector field in which each point in space is associated 279 | -- with a unit vector in the direction of increasing Cartesian coordinate 280 | -- z, while Cartesian coordinates x and y 281 | -- are held constant. 282 | -- Defined everywhere. 283 | zHat :: Field Vec 284 | zHat = const kHat 285 | -------------------------------------------------------------------------------- /src/Physics/Learn/QuantumMat.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE Trustworthy #-} 3 | {-# LANGUAGE CPP #-} 4 | 5 | {- | 6 | Module : Physics.Learn.QuantumMat 7 | Copyright : (c) Scott N. Walck 2016-2018 8 | License : BSD3 (see LICENSE) 9 | Maintainer : Scott N. Walck 10 | Stability : experimental 11 | 12 | This module contains state vectors and matrices 13 | for quantum mechanics. 14 | -} 15 | 16 | -- Using only Complex Double here, no cyclotomic 17 | 18 | module Physics.Learn.QuantumMat 19 | ( 20 | -- * Complex numbers 21 | C 22 | -- * State Vectors 23 | , xp 24 | , xm 25 | , yp 26 | , ym 27 | , zp 28 | , zm 29 | , np 30 | , nm 31 | , dim 32 | , scaleV 33 | , inner 34 | , norm 35 | , normalize 36 | , probVector 37 | , gramSchmidt 38 | , conjV 39 | , fromList 40 | , toList 41 | -- * Matrices (operators) 42 | , sx 43 | , sy 44 | , sz 45 | , scaleM 46 | , (<>) 47 | , (#>) 48 | , (<#) 49 | , conjugateTranspose 50 | , fromLists 51 | , toLists 52 | , size 53 | , matrixFunction 54 | -- * Density matrices 55 | , couter 56 | , dm 57 | , trace 58 | , normalizeDM 59 | , oneQubitMixed 60 | -- * Quantum Dynamics 61 | , timeEvMat 62 | , timeEv 63 | , timeEvMatSpec 64 | -- * Composition 65 | , Kronecker(..) 66 | -- * Measurement 67 | , possibleOutcomes 68 | , outcomesProjectors 69 | , outcomesProbabilities 70 | -- * Vector and Matrix 71 | , Vector 72 | , Matrix 73 | ) 74 | where 75 | 76 | import Numeric.LinearAlgebra 77 | ( C 78 | , Vector 79 | , Matrix 80 | , Herm 81 | , iC -- square root of negative one 82 | , (><) -- matrix definition 83 | , ident 84 | , scale 85 | , norm_2 86 | , inv 87 | , (<\>) 88 | , sym 89 | , eigenvaluesSH 90 | , eigSH 91 | , cmap 92 | , takeDiag 93 | , conj 94 | , dot 95 | , tr 96 | ) 97 | -- , (<>) -- matrix product (not * !!!!) 98 | -- , (#>) -- matrix-vector product 99 | -- , fromList -- vector definition 100 | 101 | import qualified Numeric.LinearAlgebra as H 102 | -- because H.outer does not conjugate 103 | import Data.Complex 104 | ( Complex(..) 105 | , magnitude 106 | , realPart 107 | ) 108 | #if MIN_VERSION_base(4,11,0) 109 | import Prelude hiding ((<>)) 110 | #endif 111 | 112 | -- | The state resulting from a measurement of 113 | -- spin angular momentum in the x direction 114 | -- on a spin-1/2 particle 115 | -- when the result of the measurement is hbar/2. 116 | xp :: Vector C 117 | xp = normalize $ fromList [1, 1] 118 | 119 | -- | The state resulting from a measurement of 120 | -- spin angular momentum in the x direction 121 | -- on a spin-1/2 particle 122 | -- when the result of the measurement is -hbar/2. 123 | xm :: Vector C 124 | xm = normalize $ fromList [1, -1] 125 | 126 | -- | The state resulting from a measurement of 127 | -- spin angular momentum in the y direction 128 | -- on a spin-1/2 particle 129 | -- when the result of the measurement is hbar/2. 130 | yp :: Vector C 131 | yp = normalize $ fromList [1, iC] 132 | 133 | -- | The state resulting from a measurement of 134 | -- spin angular momentum in the y direction 135 | -- on a spin-1/2 particle 136 | -- when the result of the measurement is -hbar/2. 137 | ym :: Vector C 138 | ym = normalize $ fromList [1, -iC] 139 | 140 | -- | The state resulting from a measurement of 141 | -- spin angular momentum in the z direction 142 | -- on a spin-1/2 particle 143 | -- when the result of the measurement is hbar/2. 144 | zp :: Vector C 145 | zp = normalize $ fromList [1, 0] 146 | 147 | -- | The state resulting from a measurement of 148 | -- spin angular momentum in the z direction 149 | -- on a spin-1/2 particle 150 | -- when the result of the measurement is -hbar/2. 151 | zm :: Vector C 152 | zm = normalize $ fromList [0, 1] 153 | 154 | -- | The state resulting from a measurement of 155 | -- spin angular momentum in the direction 156 | -- specified by spherical angles theta (polar angle) 157 | -- and phi (azimuthal angle) 158 | -- on a spin-1/2 particle 159 | -- when the result of the measurement is hbar/2. 160 | np :: Double -> Double -> Vector C 161 | np theta phi = fromList [ cos (theta/2) :+ 0 162 | , exp(0 :+ phi) * (sin (theta/2) :+ 0) ] 163 | 164 | -- | The state resulting from a measurement of 165 | -- spin angular momentum in the direction 166 | -- specified by spherical angles theta (polar angle) 167 | -- and phi (azimuthal angle) 168 | -- on a spin-1/2 particle 169 | -- when the result of the measurement is -hbar/2. 170 | nm :: Double -> Double -> Vector C 171 | nm theta phi = fromList [ sin (theta/2) :+ 0 172 | , -exp(0 :+ phi) * (cos (theta/2) :+ 0) ] 173 | 174 | -- | Dimension of a vector. 175 | dim :: Vector C -> Int 176 | dim = H.size 177 | 178 | -- | Scale a complex vector by a complex number. 179 | scaleV :: C -> Vector C -> Vector C 180 | scaleV = scale 181 | 182 | -- | Complex inner product. First vector gets conjugated. 183 | inner :: Vector C -> Vector C -> C 184 | inner = dot 185 | 186 | -- | Length of a complex vector. 187 | norm :: Vector C -> Double 188 | norm = norm_2 189 | 190 | -- | Return a normalized version of a given state vector. 191 | normalize :: Vector C -> Vector C 192 | normalize v = scale (1 / norm_2 v :+ 0) v 193 | 194 | -- | Return a vector of probabilities for a given state vector. 195 | probVector :: Vector C -- ^ state vector 196 | -> Vector Double -- ^ vector of probabilities 197 | probVector = cmap (\c -> magnitude c**2) 198 | 199 | -- | Conjugate the entries of a vector. 200 | conjV :: Vector C -> Vector C 201 | conjV = conj 202 | 203 | -- | Construct a vector from a list of complex numbers. 204 | fromList :: [C] -> Vector C 205 | fromList = H.fromList 206 | 207 | -- | Produce a list of complex numbers from a vector. 208 | toList :: Vector C -> [C] 209 | toList = H.toList 210 | 211 | -------------- 212 | -- Matrices -- 213 | -------------- 214 | 215 | -- | The Pauli X matrix. 216 | sx :: Matrix C 217 | sx = (2><2) [ 0, 1 218 | , 1, 0 ] 219 | 220 | -- | The Pauli Y matrix. 221 | sy :: Matrix C 222 | sy = (2><2) [ 0, -iC 223 | , iC, 0 ] 224 | 225 | -- | The Pauli Z matrix. 226 | sz :: Matrix C 227 | sz = (2><2) [ 1, 0 228 | , 0, -1 ] 229 | 230 | -- | Scale a complex matrix by a complex number. 231 | scaleM :: C -> Matrix C -> Matrix C 232 | scaleM = scale 233 | 234 | -- | Matrix product. 235 | (<>) :: Matrix C -> Matrix C -> Matrix C 236 | (<>) = (H.<>) 237 | 238 | -- | Matrix-vector product. 239 | (#>) :: Matrix C -> Vector C -> Vector C 240 | (#>) = (H.#>) 241 | 242 | -- | Vector-matrix product 243 | (<#) :: Vector C -> Matrix C -> Vector C 244 | (<#) = (H.<#) 245 | 246 | -- | Conjugate transpose of a matrix. 247 | conjugateTranspose :: Matrix C -> Matrix C 248 | conjugateTranspose = tr 249 | 250 | -- | Construct a matrix from a list of lists of complex numbers. 251 | fromLists :: [[C]] -> Matrix C 252 | fromLists = H.fromLists 253 | 254 | -- | Produce a list of lists of complex numbers from a matrix. 255 | toLists :: Matrix C -> [[C]] 256 | toLists = H.toLists 257 | 258 | -- | Size of a matrix. 259 | size :: Matrix C -> (Int,Int) 260 | size = H.size 261 | 262 | -- | Apply a function to a matrix. 263 | -- Assumes the matrix is a normal matrix (a matrix 264 | -- with an orthonormal basis of eigenvectors). 265 | matrixFunction :: (C -> C) -> Matrix C -> Matrix C 266 | matrixFunction f m 267 | = let (valv,vecm) = H.eig m 268 | fvalv = fromList [f val | val <- toList valv] 269 | in vecm <> H.diag fvalv <> tr vecm 270 | 271 | ---------------------- 272 | -- Density Matrices -- 273 | ---------------------- 274 | 275 | -- | Complex outer product 276 | couter :: Vector C -> Vector C -> Matrix C 277 | couter v w = v `H.outer` conj w 278 | 279 | -- | Build a pure-state density matrix from a state vector. 280 | dm :: Vector C -> Matrix C 281 | dm cvec = cvec `couter` cvec 282 | 283 | -- | Trace of a matrix. 284 | trace :: Matrix C -> C 285 | trace = sum . toList . takeDiag 286 | 287 | -- | Normalize a density matrix so that it has trace one. 288 | normalizeDM :: Matrix C -> Matrix C 289 | normalizeDM rho = scale (1 / trace rho) rho 290 | 291 | -- | The one-qubit totally mixed state. 292 | oneQubitMixed :: Matrix C 293 | oneQubitMixed = normalizeDM $ ident 2 294 | 295 | ---------------------- 296 | -- Quantum Dynamics -- 297 | ---------------------- 298 | 299 | -- | Given a time step and a Hamiltonian matrix, 300 | -- produce a unitary time evolution matrix. 301 | -- Unless you really need the time evolution matrix, 302 | -- it is better to use 'timeEv', which gives the 303 | -- same numerical results without doing an explicit 304 | -- matrix inversion. The function assumes hbar = 1. 305 | timeEvMat :: Double -> Matrix C -> Matrix C 306 | timeEvMat dt h 307 | = let ah = scale (0 :+ dt / 2) h 308 | (l,m) = size h 309 | n = if l == m then m else error "timeEv needs square Hamiltonian" 310 | identity = ident n 311 | in inv (identity + ah) <> (identity - ah) 312 | 313 | -- | Given a time step and a Hamiltonian matrix, 314 | -- advance the state vector using the Schrodinger equation. 315 | -- This method should be faster than using 'timeEvMat' 316 | -- since it solves a linear system rather than calculating 317 | -- an inverse matrix. The function assumes hbar = 1. 318 | timeEv :: Double -> Matrix C -> Vector C -> Vector C 319 | timeEv dt h v 320 | = let ah = scale (0 :+ dt / 2) h 321 | (l,m) = size h 322 | n = if l == m then m else error "timeEv needs square Hamiltonian" 323 | identity = ident n 324 | in (identity + ah) <\> ((identity - ah) #> v) 325 | 326 | -- | Given a Hamiltonian matrix, return a function from time 327 | -- to evolution matrix. Uses spectral decomposition. 328 | -- Assumes hbar = 1. 329 | timeEvMatSpec :: Matrix C -> Double -> Matrix C 330 | timeEvMatSpec m t = matrixFunction (\h -> exp(-iC * h * (t :+ 0))) m 331 | 332 | ----------------- 333 | -- Composition -- 334 | ----------------- 335 | 336 | class Kronecker a where 337 | kron :: a -> a -> a 338 | 339 | instance H.Product t => Kronecker (Vector t) where 340 | kron v1 v2 = H.fromList [c1 * c2 | c1 <- H.toList v1, c2 <- H.toList v2] 341 | 342 | instance H.Product t => Kronecker (Matrix t) where 343 | kron = H.kronecker 344 | 345 | ----------------- 346 | -- Measurement -- 347 | ----------------- 348 | 349 | -- | The possible outcomes of a measurement 350 | -- of an observable. 351 | -- These are the eigenvalues of the matrix 352 | -- of the observable. 353 | possibleOutcomes :: Matrix C -> [Double] 354 | possibleOutcomes observable 355 | = H.toList $ eigenvaluesSH (sym observable) 356 | 357 | -- From a Hermitian matrix, a list of pairs of eigenvalues and eigenvectors. 358 | valsVecs :: Herm C -> [(Double,Vector C)] 359 | valsVecs h = let (valv,m) = eigSH h 360 | vals = H.toList valv 361 | vecs = map (conjV . fromList) $ toLists (conjugateTranspose m) 362 | in zip vals vecs 363 | 364 | -- From a Hermitian matrix, a list of pairs of eigenvalues and projectors. 365 | valsPs :: Herm C -> [(Double,Matrix C)] 366 | valsPs h = [(val,couter vec vec) | (val,vec) <- valsVecs h] 367 | 368 | combineFst :: (Eq a, Num b) => [(a,b)] -> [(a,b)] 369 | combineFst [] = [] 370 | combineFst [p] = [p] 371 | combineFst ((x1,m1):(x2,m2):ps) 372 | = if x1 == x2 373 | then combineFst ((x1,m1+m2):ps) 374 | else (x1,m1):combineFst ((x2,m2):ps) 375 | 376 | -- | Given an obervable, return a list of pairs 377 | -- of possible outcomes and projectors 378 | -- for each outcome. 379 | outcomesProjectors :: Matrix C -> [(Double,Matrix C)] 380 | outcomesProjectors m = combineFst (valsPs (sym m)) 381 | 382 | -- | Given an observable and a state vector, return a list of pairs 383 | -- of possible outcomes and probabilites 384 | -- for each outcome. 385 | outcomesProbabilities :: Matrix C -> Vector C -> [(Double,Double)] 386 | outcomesProbabilities m v 387 | = [(a,realPart (inner v (p #> v))) | (a,p) <- outcomesProjectors m] 388 | 389 | ------------------ 390 | -- Gram-Schmidt -- 391 | ------------------ 392 | 393 | -- | Form an orthonormal list of complex vectors 394 | -- from a linearly independent list of complex vectors. 395 | gramSchmidt :: [Vector C] -> [Vector C] 396 | gramSchmidt [] = [] 397 | gramSchmidt (v:vs) = let nvs = gramSchmidt vs 398 | nv = normalize (v - sum [scale (inner w v) w | w <- nvs]) 399 | in nv:nvs 400 | 401 | -- To Do 402 | -- Generate higher spin operators and state vectors 403 | -- eigenvectors 404 | -- projection operators 405 | 406 | -------------------------------------------------------------------------------- /src/Physics/Learn/RootFinding.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE Safe #-} 3 | 4 | {- | 5 | Module : Physics.Learn.RootFinding 6 | Copyright : (c) Scott N. Walck 2012-2017 7 | License : BSD3 (see LICENSE) 8 | Maintainer : Scott N. Walck 9 | Stability : experimental 10 | 11 | Functions for approximately solving equations like f(x) = 0. 12 | These functions proceed by assuming that f is continuous, 13 | and that a root is bracketed. A bracket around a root consists 14 | of numbers a, b such that f(a) f(b) <= 0. Since the product 15 | changes sign, there must be an x with a < x < b such that f(x) = 0. 16 | -} 17 | 18 | module Physics.Learn.RootFinding 19 | ( findRoots 20 | , findRootsN 21 | , findRoot 22 | , bracketRoot 23 | , bracketRootStep 24 | ) 25 | where 26 | 27 | -- | Given an initial bracketing of a root 28 | -- (an interval (a,b) for which f(a) f(b) <= 0), 29 | -- produce a bracket (c,d) for which |c-d| < desired accuracy. 30 | bracketRoot :: (Ord a, Fractional a) => 31 | a -- ^ desired accuracy 32 | -> (a -> a) -- ^ function 33 | -> (a,a) -- ^ initial bracket 34 | -> (a,a) -- ^ final bracket 35 | bracketRoot dx f (a,b) 36 | = let fa = f a 37 | fb = f b 38 | bRoot ((c,fc),(d,fd)) = let m = (c + d) / 2 39 | fm = f m 40 | in if abs (c - d) < dx 41 | then (c,d) 42 | else if fc * fm <= 0 43 | then bRoot ((c,fc),(m,fm)) 44 | else bRoot ((m,fm),(d,fd)) 45 | in if fa * fb > 0 46 | then error "bracketRoot: initial interval is not a bracket" 47 | else bRoot ((a,fa),(b,fb)) 48 | 49 | -- | Given a bracketed root, return a half-width bracket. 50 | bracketRootStep :: (Ord a, Fractional a) => 51 | (a -> a) -- ^ function 52 | -> ((a,a),(a,a)) -- ^ original bracket 53 | -> ((a,a),(a,a)) -- ^ new bracket 54 | bracketRootStep f ((a,fa),(b,fb)) 55 | = let m = (a + b) / 2 56 | fm = f m 57 | in if fa * fm <= 0 58 | then ((a,fa),(m,fm)) 59 | else ((m,fm),(b,fb)) 60 | 61 | findRootMachinePrecision :: (Double -> Double) 62 | -> ((Double,Double),(Double,Double)) 63 | -> Double 64 | findRootMachinePrecision f ((c,fc),(d,fd)) 65 | = let m = (c + d) / 2 66 | fm = f m 67 | in if fc == 0 68 | then c 69 | else if fd == 0 70 | then d 71 | else if c == m 72 | then c 73 | else if m == d 74 | then d 75 | else if fc * fm <= 0 76 | then findRootMachinePrecision f ((c,fc),(m,fm)) 77 | else findRootMachinePrecision f ((m,fm),(d,fd)) 78 | 79 | -- | Find a single root in a bracketed region. 80 | -- The algorithm continues until it exhausts the 81 | -- precision of a 'Double'. This could cause the function to hang. 82 | findRoot :: (Double -> Double) -- ^ function 83 | -> (Double,Double) -- ^ initial bracket 84 | -> Double -- ^ approximate root 85 | findRoot f (a,b) 86 | = let fa = f a 87 | fb = f b 88 | in if fa * fb > 0 89 | then error "bracketRoot: initial interval is not a bracket" 90 | else findRootMachinePrecision f ((a,fa),(b,fb)) 91 | 92 | -- | Find a list of roots for a function over a given range. 93 | -- First parameter is the initial number of intervals to 94 | -- use to find the roots. If roots are closely spaced, 95 | -- this number of intervals may need to be large. 96 | findRootsN :: Int -- ^ initial number of intervals to use 97 | -> (Double -> Double) -- ^ function 98 | -> (Double,Double) -- ^ range over which to search 99 | -> [Double] -- ^ list of roots 100 | findRootsN n f (a,b) 101 | = let dx = (b - a) / fromIntegral n 102 | xs = [a,a+dx..b] 103 | in map (findRootMachinePrecision f) [((x0,fx0),(x1,fx1)) | (x0,x1) <- zip xs (tail xs), let fx0 = f x0, let fx1 = f x1, fx0 * fx1 <= 0] 104 | 105 | -- | Find a list of roots for a function over a given range. 106 | -- There are no guarantees that all roots will be found. 107 | -- Uses 'findRootsN' with 1000 intervals. 108 | findRoots :: (Double -> Double) -- ^ function 109 | -> (Double,Double) -- ^ range over which to search 110 | -> [Double] -- ^ list of roots 111 | findRoots = findRootsN 1000 112 | -------------------------------------------------------------------------------- /src/Physics/Learn/RungeKutta.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE Safe #-} 4 | 5 | {- | 6 | Module : Physics.Learn.RungeKutta 7 | Copyright : (c) Scott N. Walck 2012-2019 8 | License : BSD3 (see LICENSE) 9 | Maintainer : Scott N. Walck 10 | Stability : experimental 11 | 12 | Differential equation solving using 4th-order Runge-Kutta 13 | -} 14 | 15 | module Physics.Learn.RungeKutta 16 | ( rungeKutta4 17 | , integrateSystem 18 | ) 19 | where 20 | 21 | import Physics.Learn.StateSpace 22 | ( StateSpace(..) 23 | , Diff 24 | , Time 25 | , (.+^) 26 | ) 27 | import Data.VectorSpace 28 | ( (^+^) 29 | , (*^) 30 | , (^/) 31 | ) 32 | 33 | -- | Take a single 4th-order Runge-Kutta step 34 | rungeKutta4 :: StateSpace p => (p -> Diff p) -> Time p -> p -> p 35 | rungeKutta4 f dt y 36 | = let k0 = dt *^ f y 37 | k1 = dt *^ f (y .+^ k0 ^/ 2) 38 | k2 = dt *^ f (y .+^ k1 ^/ 2) 39 | k3 = dt *^ f (y .+^ k2) 40 | in y .+^ (k0 ^+^ 2 *^ k1 ^+^ 2 *^ k2 ^+^ k3) ^/ 6 41 | 42 | -- | Solve a first-order system of differential equations with 4th-order Runge-Kutta 43 | integrateSystem :: StateSpace p => (p -> Diff p) -> Time p -> p -> [p] 44 | integrateSystem systemDerivative dt 45 | = iterate (rungeKutta4 systemDerivative dt) 46 | 47 | 48 | 49 | {- 50 | -- | Take a single 4th-order Runge-Kutta step 51 | rungeKutta4 :: (VectorSpace v, Fractional (Scalar v)) => (v -> v) -> Scalar v -> v -> v 52 | rungeKutta4 f h y 53 | = let k0 = h *^ f y 54 | k1 = h *^ f (y ^+^ k0 ^/ 2) 55 | k2 = h *^ f (y ^+^ k1 ^/ 2) 56 | k3 = h *^ f (y ^+^ k2) 57 | in y ^+^ (k0 ^+^ 2 *^ k1 ^+^ 2 *^ k2 ^+^ k3) ^/ 6 58 | 59 | -- | Solve a first-order system of differential equations with 4th-order Runge-Kutta 60 | integrateSystem :: (VectorSpace v, Fractional (Scalar v)) => (v -> v) -> Scalar v -> v -> [v] 61 | integrateSystem systemDerivative dt 62 | = iterate (rungeKutta4 systemDerivative dt) 63 | -} 64 | -------------------------------------------------------------------------------- /src/Physics/Learn/Schrodinger1D.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | 4 | -- | 5 | -- Module : Physics.Learn.Schrodinger1D 6 | -- Copyright : (c) Scott N. Walck 2015-2018 7 | -- License : BSD3 (see LICENSE) 8 | -- Maintainer : Scott N. Walck 9 | -- Stability : experimental 10 | -- 11 | -- This module contains functions to 12 | -- solve the (time dependent) Schrodinger equation 13 | -- in one spatial dimension for a given potential function. 14 | module Physics.Learn.Schrodinger1D 15 | ( -- * Potentials 16 | freeV 17 | , harmonicV 18 | , squareWell 19 | , doubleWell 20 | , stepV 21 | , wall 22 | 23 | -- * Initial wavefunctions 24 | 25 | -- , harm 26 | , coherent 27 | , gaussian 28 | , movingGaussian 29 | 30 | -- * Utilities 31 | , stateVectorFromWavefunction 32 | , hamiltonianMatrix 33 | , expectX 34 | , picture 35 | , xRange 36 | , listForm 37 | , fact 38 | ) 39 | where 40 | 41 | import Data.Complex 42 | ( Complex (..) 43 | , magnitude 44 | ) 45 | import Graphics.Gloss 46 | ( Picture (..) 47 | , yellow 48 | ) 49 | -- import Math.Polynomial.Hermite 50 | -- ( evalPhysHermite 51 | -- ) 52 | import Numeric.LinearAlgebra 53 | ( C 54 | , Matrix 55 | , R 56 | , Vector 57 | , fromLists 58 | , size 59 | , toList 60 | , (<.>) 61 | , (|>) 62 | ) 63 | import Physics.Learn.QuantumMat 64 | ( probVector 65 | ) 66 | 67 | -- i :: Complex Double 68 | -- i = 0 :+ 1 69 | 70 | ---------------- 71 | -- Potentials -- 72 | ---------------- 73 | 74 | -- | Free potential. 75 | -- The potential energy is zero everywhere. 76 | freeV 77 | :: Double 78 | -- ^ position 79 | -> Double 80 | -- ^ potential energy 81 | freeV _x = 0 82 | 83 | -- | Harmonic potential. 84 | -- This is the potential energy of a linear spring. 85 | harmonicV 86 | :: Double 87 | -- ^ spring constant 88 | -> Double 89 | -- ^ position 90 | -> Double 91 | -- ^ potential energy 92 | harmonicV k x = k * x ** 2 / 2 93 | 94 | -- | A double well potential. 95 | -- Potential energy is a quartic function of position 96 | -- that gives two wells, each approximately harmonic 97 | -- at the bottom of the well. 98 | doubleWell 99 | :: Double 100 | -- ^ width (for both wells and well separation) 101 | -> Double 102 | -- ^ energy height of barrier between wells 103 | -> Double 104 | -- ^ position 105 | -> Double 106 | -- ^ potential energy 107 | doubleWell a v0 x = v0 * ((x ** 2 - a ** 2) / a ** 2) ** 2 108 | 109 | -- | Finite square well potential. 110 | -- Potential is zero inside the well, 111 | -- and constant outside the well. 112 | -- Well is centered at the origin. 113 | squareWell 114 | :: Double 115 | -- ^ well width 116 | -> Double 117 | -- ^ energy height of well 118 | -> Double 119 | -- ^ position 120 | -> Double 121 | -- ^ potential energy 122 | squareWell l v0 x 123 | | abs x < l / 2 = 0 124 | | otherwise = v0 125 | 126 | -- | A step barrier potential. 127 | -- Potential is zero to left of origin. 128 | stepV 129 | :: Double 130 | -- ^ energy height of barrier (to the right of origin) 131 | -> Double 132 | -- ^ position 133 | -> Double 134 | -- ^ potential energy 135 | stepV v0 x 136 | | x < 0 = 0 137 | | otherwise = v0 138 | 139 | -- | A potential barrier with thickness and height. 140 | wall 141 | :: Double 142 | -- ^ thickness of wall 143 | -> Double 144 | -- ^ energy height of barrier 145 | -> Double 146 | -- ^ position of center of barrier 147 | -> Double 148 | -- ^ position 149 | -> Double 150 | -- ^ potential energy 151 | wall w v0 x0 x 152 | | abs (x - x0) < w / 2 = v0 153 | | otherwise = 0 154 | 155 | --------------------------- 156 | -- Initial wavefunctions -- 157 | --------------------------- 158 | 159 | -- -- | Harmonic oscillator stationary state 160 | -- harm :: Int -- ^ nonnegative integer n identifying stationary state 161 | -- -> Double -- ^ x / sqrt(hbar/(m * omega)), i.e. position 162 | -- -- in units of sqrt(hbar/(m * omega)) 163 | -- -> C -- ^ complex amplitude 164 | -- harm n u 165 | -- = exp (-u**2/2) * evalPhysHermite n u / sqrt (2^n * fact n * sqrt pi) :+ 0 166 | 167 | coherent 168 | :: R 169 | -- ^ length scale = sqrt(hbar / m omega) 170 | -> C 171 | -- ^ parameter z 172 | -> R 173 | -> C 174 | -- ^ wavefunction 175 | coherent l z x = 176 | ((1 / (pi * l ** 2)) ** 0.25 * exp (-x ** 2 / (2 * l ** 2)) :+ 0) 177 | * exp (-z ** 2 / 2 + (sqrt (2 / l ** 2) * x :+ 0) * z) 178 | 179 | gaussian 180 | :: R 181 | -- ^ width parameter 182 | -> R 183 | -- ^ center of wave packet 184 | -> R 185 | -> C 186 | -- ^ wavefunction 187 | gaussian a x0 x = exp (-(x - x0) ** 2 / (2 * a ** 2)) / sqrt (a * sqrt pi) :+ 0 188 | 189 | movingGaussian 190 | :: R 191 | -- ^ width parameter 192 | -> R 193 | -- ^ center of wave packet 194 | -> R 195 | -- ^ l0 = hbar / p0 196 | -> R 197 | -> C 198 | -- ^ wavefunction 199 | movingGaussian a x0 l0 x = exp ((0 :+ x / l0) - ((x - x0) ** 2 / (2 * a ** 2) :+ 0)) / (sqrt (a * sqrt pi) :+ 0) 200 | 201 | --------------- 202 | -- Utilities -- 203 | --------------- 204 | 205 | fact :: Int -> Double 206 | fact 0 = 1 207 | fact n = fromIntegral n * fact (n - 1) 208 | 209 | linspace :: Double -> Double -> Int -> [Double] 210 | linspace left right num = 211 | let dx = (right - left) / fromIntegral (num - 1) 212 | in [left + dx * fromIntegral n | n <- [0 .. num - 1]] 213 | 214 | -- | Transform a wavefunction into a state vector. 215 | stateVectorFromWavefunction 216 | :: R 217 | -- ^ lowest x 218 | -> R 219 | -- ^ highest x 220 | -> Int 221 | -- ^ dimension of state vector 222 | -> (R -> C) 223 | -- ^ wavefunction 224 | -> Vector C 225 | -- ^ state vector 226 | stateVectorFromWavefunction left right num psi = 227 | (num |>) [psi x | x <- linspace left right num] 228 | 229 | hamiltonianMatrix 230 | :: R 231 | -- ^ lowest x 232 | -> R 233 | -- ^ highest x 234 | -> Int 235 | -- ^ dimension of state vector 236 | -> R 237 | -- ^ hbar 238 | -> R 239 | -- ^ mass 240 | -> (R -> R) 241 | -- ^ potential energy function 242 | -> Matrix C 243 | -- ^ Hamiltonian Matrix 244 | hamiltonianMatrix xmin xmax num hbar m pe = 245 | let coeff = -hbar ** 2 / (2 * m) 246 | dx = (xmax - xmin) / fromIntegral (num - 1) 247 | diagKEterm = -2 * coeff / dx ** 2 248 | offdiagKEterm = coeff / dx ** 2 249 | xs = linspace xmin xmax num 250 | in fromLists 251 | [ [ case abs (i - j) of 252 | 0 -> (diagKEterm + pe x) :+ 0 253 | 1 -> offdiagKEterm :+ 0 254 | _ -> 0 255 | | j <- [1 .. num] 256 | ] 257 | | (i, x) <- zip [1 .. num] xs 258 | ] 259 | 260 | expectX 261 | :: Vector C 262 | -- ^ state vector 263 | -> Vector R 264 | -- ^ vector of x values 265 | -> R 266 | -- ^ , expectation value of X 267 | expectX psi xs = probVector psi <.> xs 268 | 269 | glossScaleX :: Int -> (Double, Double) -> Double -> Float 270 | glossScaleX screenWidth (xmin, xmax) x = 271 | let w = fromIntegral screenWidth :: Double 272 | in realToFrac $ (x - xmin) / (xmax - xmin) * w - w / 2 273 | 274 | glossScaleY :: Int -> (Double, Double) -> Double -> Float 275 | glossScaleY screenHeight (ymin, ymax) y = 276 | let h = fromIntegral screenHeight :: Double 277 | in realToFrac $ (y - ymin) / (ymax - ymin) * h - h / 2 278 | 279 | glossScalePoint 280 | :: (Int, Int) 281 | -- ^ (screenWidth,screenHeight) 282 | -> (Double, Double) 283 | -- ^ (xmin,xmax) 284 | -> (Double, Double) 285 | -- ^ (ymin,ymax) 286 | -> (Double, Double) 287 | -- ^ (x,y) 288 | -> (Float, Float) 289 | glossScalePoint (screenWidth, screenHeight) xMinMax yMinMax (x, y) = 290 | ( glossScaleX screenWidth xMinMax x 291 | , glossScaleY screenHeight yMinMax y 292 | ) 293 | 294 | -- | Produce a gloss 'Picture' of state vector 295 | -- for 1D wavefunction. 296 | picture 297 | :: (Double, Double) 298 | -- ^ y range 299 | -> [Double] 300 | -- ^ xs 301 | -> Vector C 302 | -- ^ state vector 303 | -> Picture 304 | picture (ymin, ymax) xs psi = 305 | Color 306 | yellow 307 | ( Line 308 | [ glossScalePoint 309 | (screenWidth, screenHeight) 310 | (head xs, last xs) 311 | (ymin, ymax) 312 | p 313 | | p <- zip xs (map magSq $ toList psi) 314 | ] 315 | ) 316 | where 317 | magSq = \z -> magnitude z ** 2 318 | screenWidth = 1000 319 | screenHeight = 750 320 | 321 | -- options for representing wave functions 322 | -- 1. A function R -> C 323 | -- 2. ([R],Vector C), where lengths match 324 | -- 3. [(R,C)] 325 | -- 4. (R,R,Vector C) -- xmin, xmax, state vector (assumes even spacing) 326 | 327 | -- 2,4 are best for evolution 328 | 329 | listForm :: (R, R, Vector C) -> ([R], Vector C) 330 | listForm (xmin, xmax, v) = 331 | let dt = (xmax - xmin) / fromIntegral (size v - 1) 332 | in ([xmin, xmin + dt .. xmax], v) 333 | 334 | {- 335 | -- | Given an initial state vector and 336 | -- state propagation function, produce a simulation. 337 | -- The 'Float' in the state propagation function is the time 338 | -- interval for one timestep. 339 | simulate1D :: [Double] -> Vector C -> (Float -> (Float,[Double],Vector C) -> (Float,[Double],Vector C)) -> IO () 340 | simulate1D xs initial statePropFunc 341 | = simulate display black 10 (0,initial) displayFunc (const statePropFunc) 342 | where 343 | display = InWindow "Animation" (screenWidth,screenHeight) (10,10) 344 | displayFunc (_t,v) = Color yellow (Line [( 345 | 346 | white (\tFloat -> Pictures [Color blue (Line (points (realToFrac tFloat))) 347 | ,axes (screenWidth,screenHeight) (xmin,xmax) (ymin,ymax)]) 348 | 349 | -- | Produce a state propagation function from a time-dependent Hamiltonian. 350 | -- The float is dt. 351 | statePropGloss :: (Double -> Matrix C) -> Float -> (Float,Vector C) -> (Float,Vector C) 352 | statePropGloss ham dt (tOld,v) 353 | = (tNew, timeEv (realToFrac dt) (ham tMid) v) 354 | where 355 | tNew = tOld + dt 356 | tMid = realToFrac $ (tNew + tOld) / 2 357 | 358 | -- | Given an initial state vector and a time-dependent Hamiltonian, 359 | -- produce a visualization of a 1D wavefunction. 360 | evolutionBlochSphere :: Vector C -> (Double -> Matrix C) -> IO () 361 | evolutionBlochSphere psi0 ham 362 | = simulateBlochSphere 0.01 psi0 (stateProp ham) 363 | 364 | -} 365 | 366 | {- 367 | def triDiagMatrixMult(square_arr,arr): 368 | num = len(arr) 369 | result = array([0 for n in range(num)],dtype=complex128) 370 | result[0] = square_arr[0][0] * arr[0] + square_arr[0][1] * arr[1] 371 | for n in range(1,num-1): 372 | result[n] = square_arr[n][n-1] * arr[n-1] + square_arr[n][n] * arr[n] \ 373 | + square_arr[n][n+1] * arr[n+1] 374 | result[num-1] = square_arr[num-1][num-2] * arr[num-2] \ 375 | + square_arr[num-1][num-1] * arr[num-1] 376 | return result 377 | -} 378 | 379 | ------------------ 380 | -- Main program -- 381 | ------------------ 382 | 383 | -- n is number of points 384 | -- n-1 is number of intervals 385 | xRange :: R -> R -> Int -> [R] 386 | xRange xmin xmax n = 387 | let dt = (xmax - xmin) / fromIntegral (n - 1) 388 | in [xmin, xmin + dt .. xmax] 389 | 390 | {- 391 | if __name__ == '__main__': 392 | m = 1 393 | omega = 10 394 | xmin = -2.0 395 | xmax = 2.0 396 | num = 256 397 | num = 128 398 | dt = 0.0002 399 | dt = 0.01 400 | xs = linspace(xmin,xmax,num) 401 | dx = xs[1] - xs[0] 402 | 403 | super = lambda x: (harm0(m,omega)(x) + harm1(m,omega)(x))/sqrt(2) 404 | shiftedHarm = lambda x: harm0(m,omega)(x-1) 405 | coh = coherent(m,omega,1) 406 | 407 | print sum(conj(psi)*psi)*dx 408 | 409 | harmV = harmonicV(m * omega**2) 410 | 411 | V = doubleWell(1,0.1*hbar*omega) 412 | V = squareWell(1.0,hbar*omega) 413 | V = harmonicV(m*omega**2) 414 | V = stepV(10*hbar*omega) 415 | V = wall(0.1,14.0*hbar*omega,0) 416 | V = freeV 417 | 418 | H = matrixH(m,xmin,xmax,num,V) 419 | I = matrixI(num) 420 | 421 | (vals,vecs) = eigh(H) 422 | 423 | E0 = vals[0] 424 | E1 = vals[1] 425 | psi0 = normalize(transpose(vecs)[0],dx) 426 | psi1 = normalize(transpose(vecs)[1],dx) 427 | 428 | psi = func2psi(gaussian(0.3,1),xmin,xmax,num) 429 | psi = func2psi(coh,xmin,xmax,num) 430 | psi = func2psi(movingGaussian(0.3,10,-1),xmin,xmax,num) 431 | 432 | psi = psi0 433 | psi = psi1 434 | psi = (psi0 + psi1)/sqrt(2) 435 | 436 | E = sum(conj(psi)*triDiagMatrixMult(H,psi)).real*dx 437 | 438 | Escale = hbar*omega 439 | 440 | print E 441 | print Escale 442 | 443 | leftM = I + 0.5 * i * H / hbar * dt 444 | rightM = I - 0.5 * i * H / hbar * dt 445 | 446 | box = display(title='Schrodinger Equation',width=1000,height=1000) 447 | 448 | c = curve(pos = psi2rho(psi,xs)) 449 | c.color = color.blue 450 | c.radius = 0.02 451 | 452 | ball = sphere(radius=0.05,color=color.red,pos=(expectX(psi,xs),0,0)) 453 | 454 | pot_curve = [(x,V(x)/Escale,0) for x in xs if V(x)/Escale < xmax] 455 | pot = curve(color=color.green,pos=pot_curve,radius=0.01) 456 | 457 | Eline = curve(color=(1,1,0),pos=[(x,E/Escale) for x in xs]) 458 | axis = curve(color=color.white,pos=[(x,0) for x in xs]) 459 | 460 | while 1: 461 | psi = solve(leftM,triDiagMatrixMult(rightM,psi)) 462 | c.pos = psi2rho(psi,xs) 463 | ball.x = expectX(psi,xs) 464 | 465 | To Do: 466 | add combinators for potentials 467 | to shift horizontally and vertically, 468 | and to add potentials 469 | 470 | -} 471 | 472 | -- Are we committed to SI units for hbar? No. 473 | -- harmonic oscillator functions depend only on sqrt(hbar/m omega) 474 | -- which is a length parameter 475 | -- for moving gaussian, could give hbar/p0 instead of p0 476 | -- (is that debrogie wavelength? I think it's h/p0) 477 | -------------------------------------------------------------------------------- /src/Physics/Learn/SimpleVec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | {-# LANGUAGE Safe #-} 3 | 4 | {- | 5 | Module : Physics.Learn.SimpleVec 6 | Copyright : (c) Scott N. Walck 2012-2019 7 | License : BSD3 (see LICENSE) 8 | Maintainer : Scott N. Walck 9 | Stability : experimental 10 | 11 | Basic operations on the vector type 'Vec', such as vector addition 12 | and scalar multiplication. 13 | This module is simple in the sense that the operations 14 | on vectors all have simple, concrete types, 15 | without the need for type classes. 16 | This makes using and reasoning about vector operations 17 | easier for a person just learning Haskell. 18 | -} 19 | 20 | module Physics.Learn.SimpleVec 21 | ( Vec 22 | , R 23 | , xComp 24 | , yComp 25 | , zComp 26 | , vec 27 | , (^+^) 28 | , (^-^) 29 | , (*^) 30 | , (^*) 31 | , (^/) 32 | , (<.>) 33 | , (><) 34 | , magnitude 35 | , zeroV 36 | , negateV 37 | , sumV 38 | , iHat 39 | , jHat 40 | , kHat 41 | ) 42 | where 43 | 44 | import Physics.Learn.CommonVec 45 | ( Vec(..) 46 | , R 47 | , vec 48 | , iHat 49 | , jHat 50 | , kHat 51 | , (><) 52 | ) 53 | 54 | infixl 6 ^+^ 55 | infixl 6 ^-^ 56 | infixl 7 *^ 57 | infixl 7 ^* 58 | infixl 7 ^/ 59 | infixl 7 <.> 60 | 61 | -- | The zero vector. 62 | zeroV :: Vec 63 | zeroV = vec 0 0 0 64 | 65 | -- | The additive inverse of a vector. 66 | negateV :: Vec -> Vec 67 | negateV (Vec ax ay az) = Vec (-ax) (-ay) (-az) 68 | 69 | -- | Sum of a list of vectors. 70 | sumV :: [Vec] -> Vec 71 | sumV = foldr (^+^) zeroV 72 | 73 | -- | Vector addition. 74 | (^+^) :: Vec -> Vec -> Vec 75 | Vec ax ay az ^+^ Vec bx by bz 76 | = Vec (ax+bx) (ay+by) (az+bz) 77 | 78 | -- | Vector subtraction. 79 | (^-^) :: Vec -> Vec -> Vec 80 | Vec ax ay az ^-^ Vec bx by bz = Vec (ax-bx) (ay-by) (az-bz) 81 | 82 | -- | Scalar multiplication, where the scalar is on the left 83 | -- and the vector is on the right. 84 | (*^) :: R -> Vec -> Vec 85 | c *^ Vec ax ay az = Vec (c*ax) (c*ay) (c*az) 86 | 87 | -- | Scalar multiplication, where the scalar is on the right 88 | -- and the vector is on the left. 89 | (^*) :: Vec -> R -> Vec 90 | Vec ax ay az ^* c = Vec (c*ax) (c*ay) (c*az) 91 | 92 | -- | Division of a vector by a scalar. 93 | (^/) :: Vec -> R -> Vec 94 | Vec ax ay az ^/ c = Vec (ax/c) (ay/c) (az/c) 95 | 96 | -- | Dot product of two vectors. 97 | (<.>) :: Vec -> Vec -> R 98 | Vec ax ay az <.> Vec bx by bz = ax*bx + ay*by + az*bz 99 | 100 | -- | Magnitude of a vector. 101 | magnitude :: Vec -> R 102 | magnitude v = sqrt(v <.> v) 103 | 104 | -------------------------------------------------------------------------------- /src/Physics/Learn/StateSpace.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE Safe #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} 6 | 7 | -- | 8 | --Module : Physics.Learn.StateSpace 9 | --Copyright : (c) Scott N. Walck 2014-2019 10 | --License : BSD3 (see LICENSE) 11 | --Maintainer : Scott N. Walck 12 | --Stability : experimental 13 | -- 14 | --A 'StateSpace' is an affine space where the associated vector space 15 | --has scalars that are instances of 'Fractional'. 16 | --If p is an instance of 'StateSpace', then the associated vectorspace 17 | --'Diff' p is intended to represent the space of (time) derivatives 18 | --of paths in p. 19 | -- 20 | --'StateSpace' is very similar to Conal Elliott's 'AffineSpace'. 21 | module Physics.Learn.StateSpace 22 | ( StateSpace (..) 23 | , (.-^) 24 | , Time 25 | , DifferentialEquation 26 | , InitialValueProblem 27 | , EvolutionMethod 28 | , SolutionMethod 29 | , stepSolution 30 | , eulerMethod 31 | ) 32 | where 33 | 34 | import Data.AdditiveGroup 35 | ( AdditiveGroup (..) 36 | ) 37 | import Data.VectorSpace 38 | ( VectorSpace (..) 39 | ) 40 | import Physics.Learn.CarrotVec 41 | ( Vec 42 | , (^*) 43 | ) 44 | import Physics.Learn.Position 45 | ( Position 46 | , displacement 47 | , shiftPosition 48 | ) 49 | 50 | infixl 6 .+^, .-^ 51 | 52 | infix 6 .-. 53 | 54 | -- | An instance of 'StateSpace' is a data type that can serve as the state 55 | -- of some system. Alternatively, a 'StateSpace' is a collection of dependent 56 | -- variables for a differential equation. 57 | -- A 'StateSpace' has an associated vector space for the (time) derivatives 58 | -- of the state. The associated vector space is a linearized version of 59 | -- the 'StateSpace'. 60 | class (VectorSpace (Diff p), Fractional (Scalar (Diff p))) => StateSpace p where 61 | -- | Associated vector space 62 | type Diff p 63 | 64 | -- | Subtract points 65 | (.-.) :: p -> p -> Diff p 66 | 67 | -- | Point plus vector 68 | (.+^) :: p -> Diff p -> p 69 | 70 | -- | The scalars of the associated vector space can be thought of as time intervals. 71 | type Time p = Scalar (Diff p) 72 | 73 | -- | Point minus vector 74 | (.-^) :: StateSpace p => p -> Diff p -> p 75 | p .-^ v = p .+^ negateV v 76 | 77 | instance StateSpace Double where 78 | type Diff Double = Double 79 | (.-.) = (-) 80 | (.+^) = (+) 81 | 82 | instance StateSpace Vec where 83 | type Diff Vec = Vec 84 | (.-.) = (^-^) 85 | (.+^) = (^+^) 86 | 87 | -- | Position is not a vector, but displacement (difference in position) is a vector. 88 | instance StateSpace Position where 89 | type Diff Position = Vec 90 | (.-.) = flip displacement 91 | (.+^) = flip shiftPosition 92 | 93 | instance (StateSpace p, StateSpace q, Time p ~ Time q) => StateSpace (p, q) where 94 | type Diff (p, q) = (Diff p, Diff q) 95 | (p, q) .-. (p', q') = (p .-. p', q .-. q') 96 | (p, q) .+^ (u, v) = (p .+^ u, q .+^ v) 97 | 98 | instance 99 | ( StateSpace p 100 | , StateSpace q 101 | , StateSpace r 102 | , Time p ~ Time q 103 | , Time q ~ Time r 104 | ) 105 | => StateSpace (p, q, r) 106 | where 107 | type Diff (p, q, r) = (Diff p, Diff q, Diff r) 108 | (p, q, r) .-. (p', q', r') = (p .-. p', q .-. q', r .-. r') 109 | (p, q, r) .+^ (u, v, w) = (p .+^ u, q .+^ v, r .+^ w) 110 | 111 | inf :: a -> [a] 112 | inf x = x : inf x 113 | 114 | instance AdditiveGroup v => AdditiveGroup [v] where 115 | zeroV = inf zeroV 116 | (^+^) = zipWith (^+^) 117 | negateV = map negateV 118 | 119 | instance VectorSpace v => VectorSpace [v] where 120 | type Scalar [v] = Scalar v 121 | c *^ xs = [c *^ x | x <- xs] 122 | 123 | instance StateSpace p => StateSpace [p] where 124 | type Diff [p] = [Diff p] 125 | (.-.) = zipWith (.-.) 126 | (.+^) = zipWith (.+^) 127 | 128 | -- | A differential equation expresses how the dependent variables (state) 129 | -- change with the independent variable (time). 130 | -- A differential equation is specified by giving the (time) derivative 131 | -- of the state as a function of the state. 132 | -- The (time) derivative of a state is an element of the associated vector space. 133 | type DifferentialEquation state = state -> Diff state 134 | 135 | -- | An initial value problem is a differential equation along with an initial state. 136 | type InitialValueProblem state = (DifferentialEquation state, state) 137 | 138 | -- | A (numerical) solution method is a way of converting 139 | -- an initial value problem into a list of states (a solution). 140 | -- The list of states need not be equally spaced in time. 141 | type SolutionMethod state = InitialValueProblem state -> [state] 142 | 143 | -- | An evolution method is a way of approximating the state 144 | -- after advancing a finite interval in the independent 145 | -- variable (time) from a given state. 146 | type EvolutionMethod state = 147 | DifferentialEquation state 148 | -- ^ differential equation 149 | -> Time state 150 | -- ^ time interval 151 | -> state 152 | -- ^ initial state 153 | -> state 154 | -- ^ evolved state 155 | 156 | -- | Given an evolution method and a time step, return the solution method 157 | -- which applies the evolution method repeatedly with with given time step. 158 | -- The solution method returned will produce an infinite list of states. 159 | stepSolution :: EvolutionMethod state -> Time state -> SolutionMethod state 160 | stepSolution ev dt (de, ic) = iterate (ev de dt) ic 161 | 162 | -- | The Euler method is the simplest evolution method. 163 | -- It increments the state by the derivative times the time step. 164 | eulerMethod :: StateSpace state => EvolutionMethod state 165 | eulerMethod de dt st = st .+^ de st ^* dt 166 | -------------------------------------------------------------------------------- /src/Physics/Learn/Surface.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | {-# LANGUAGE Safe #-} 4 | 5 | {- | 6 | Module : Physics.Learn.Surface 7 | Copyright : (c) Scott N. Walck 2012-2019 8 | License : BSD3 (see LICENSE) 9 | Maintainer : Scott N. Walck 10 | Stability : experimental 11 | 12 | This module contains functions for working with 'Surface's 13 | and surface integrals over 'Surface's. 14 | -} 15 | 16 | module Physics.Learn.Surface 17 | ( 18 | -- * Surfaces 19 | Surface(..) 20 | , unitSphere 21 | , centeredSphere 22 | , sphere 23 | , northernHemisphere 24 | , disk 25 | , shiftSurface 26 | -- * Surface Integrals 27 | , surfaceIntegral 28 | , dottedSurfaceIntegral 29 | ) 30 | where 31 | 32 | import Data.VectorSpace 33 | ( VectorSpace 34 | , InnerSpace 35 | , Scalar 36 | ) 37 | import Physics.Learn.CarrotVec 38 | ( vec 39 | , (^+^) 40 | , (^-^) 41 | , (^*) 42 | , (^/) 43 | , (<.>) 44 | , (><) 45 | , magnitude 46 | , sumV 47 | ) 48 | import Physics.Learn.Position 49 | ( Position 50 | , Displacement 51 | , VectorField 52 | , Field 53 | , cart 54 | , cyl 55 | , shiftPosition 56 | , displacement 57 | ) 58 | 59 | -- | Surface is a parametrized function from two parameters to space, 60 | -- lower and upper limits on the first parameter, and 61 | -- lower and upper limits for the second parameter 62 | -- (expressed as functions of the first parameter). 63 | data Surface = Surface { surfaceFunc :: (Double,Double) -> Position -- ^ function from two parameters (s,t) into space 64 | , lowerLimit :: Double -- ^ s_l 65 | , upperLimit :: Double -- ^ s_u 66 | , lowerCurve :: Double -> Double -- ^ t_l(s) 67 | , upperCurve :: Double -> Double -- ^ t_u(s) 68 | } 69 | 70 | -- | A unit sphere, centered at the origin. 71 | unitSphere :: Surface 72 | unitSphere = Surface (\(th,phi) -> cart (sin th * cos phi) (sin th * sin phi) (cos th)) 73 | 0 pi (const 0) (const $ 2*pi) 74 | 75 | -- | A sphere with given radius centered at the origin. 76 | centeredSphere :: Double -> Surface 77 | centeredSphere r = Surface (\(th,phi) -> cart (r * sin th * cos phi) (r * sin th * sin phi) (r * cos th)) 78 | 0 pi (const 0) (const $ 2*pi) 79 | 80 | -- | Sphere with given radius and center. 81 | sphere :: Double -> Position -> Surface 82 | sphere r c = Surface (\(th,phi) -> shiftPosition (vec (r * sin th * cos phi) (r * sin th * sin phi) (r * cos th)) c) 83 | 0 pi (const 0) (const $ 2*pi) 84 | 85 | -- | The upper half of a unit sphere, centered at the origin. 86 | northernHemisphere :: Surface 87 | northernHemisphere = Surface (\(th,phi) -> cart (sin th * cos phi) (sin th * sin phi) (cos th)) 88 | 0 (pi/2) (const 0) (const $ 2*pi) 89 | 90 | -- | A disk with given radius, centered at the origin. 91 | disk :: Double -> Surface 92 | disk radius = Surface (\(s,phi) -> cyl s phi 0) 0 radius (const 0) (const (2*pi)) 93 | 94 | -- To do : boundaryOfSurface :: Surface -> Curve 95 | 96 | -- | A plane surface integral, in which area element is a scalar. 97 | surfaceIntegral :: (VectorSpace v, Scalar v ~ Double) => 98 | Int -- ^ number of intervals for first parameter, s 99 | -> Int -- ^ number of intervals for second parameter, t 100 | -> Field v -- ^ the scalar or vector field to integrate 101 | -> Surface -- ^ the surface over which to integrate 102 | -> v -- ^ the resulting scalar or vector 103 | surfaceIntegral n1 n2 field (Surface f s_l s_u t_l t_u) 104 | = sumV $ map sumV $ zipWith (zipWith (^*)) aveVals (map (map magnitude) areas) 105 | where 106 | pts = [[f (s,t) | t <- linSpaced n2 (t_l s) (t_u s)] | s <- linSpaced n1 s_l s_u] 107 | areas = zipWith (zipWith (><)) dus dvs 108 | dus = zipWith (zipWith displacement) pts (tail pts) 109 | dvs = map (\row -> zipWith displacement row (tail row)) pts 110 | vals = map (map field) pts 111 | halfAveVals = map (\row -> zipWith ave (tail row) row) vals 112 | aveVals = zipWith (zipWith ave) (tail halfAveVals) halfAveVals 113 | 114 | -- | A dotted surface integral, in which area element is a vector. 115 | dottedSurfaceIntegral :: Int -- ^ number of intervals for first parameter, s 116 | -> Int -- ^ number of intervals for second parameter, t 117 | -> VectorField -- ^ the vector field to integrate 118 | -> Surface -- ^ the surface over which to integrate 119 | -> Double -- ^ the resulting scalar 120 | dottedSurfaceIntegral n1 n2 vf (Surface f s_l s_u t_l t_u) 121 | = sum $ map sum $ zipWith (zipWith (<.>)) aveVals areas 122 | where 123 | pts = [[f (s,t) | t <- linSpaced n2 (t_l s) (t_u s)] | s <- linSpaced n1 s_l s_u] 124 | areas = zipWith (zipWith (><)) dus dvs 125 | dus = zipWith (zipWith displacement) pts (tail pts) 126 | dvs = map (\row -> zipWith displacement row (tail row)) pts 127 | vals = map (map vf) pts 128 | halfAveVals = map (\row -> zipWith ave (tail row) row) vals 129 | aveVals = zipWith (zipWith ave) (tail halfAveVals) halfAveVals 130 | 131 | {- 132 | evalSquare :: (InnerSpace v, Scalar v ~ Double) => Double -> Int -> Int 133 | -> (Vec -> v) -> Surface 134 | -> Vec -> Vec -> Vec -> Vec 135 | -> v -> v -> v -> v -> v 136 | evalSquare tol level maxlevel field (Surface f s_l s_u t_l t_u) 137 | surfll surflu surful surfuu fieldll fieldlu fieldul fielduu val 138 | = let s_m = (s_l + s_u) / 2 139 | t_m s = (t_l s + t_u s) / 2 140 | surflm = f (s_l,t_m s_l) 141 | surfum = f (s_u,t_m s_u) 142 | surfml = f (s_m,t_l s_m) 143 | surfmu = f (s_m,t_u s_m) 144 | surfmm = f (s_m,t_m s_m) 145 | fieldlm = field surflm 146 | fieldum = field surfum 147 | fieldml = field surfml 148 | fieldmu = field surfmu 149 | fieldmm = field surfmm 150 | dull = surfml ^-^ surfll 151 | dulu = surfmm ^-^ surflm 152 | duul = surful ^-^ surfml 153 | duuu = surfum ^-^ surfmm 154 | dvll = surflm ^-^ surfll 155 | dvlu = surflu ^-^ surflm 156 | dvul = surfmm ^-^ surfml 157 | dvuu = surfmu ^-^ surfmm 158 | areall = dull >< dvll 159 | arealu = dulu >< dvlu 160 | areaul = duul >< dvul 161 | areauu = duuu >< dvuu 162 | valll = average [fieldll,fieldlm,fieldml,fieldmm] <.> areall 163 | vallu = average [fieldlm,fieldlu,fieldmm,fieldmu] <.> arealu 164 | valul = average [fieldml,fieldmm,fieldul,fieldum] <.> areaul 165 | valuu = average [fieldmm,fieldmu,fieldum,fielduu] <.> areauu 166 | newval = valll ^+^ vallu ^+^ valul ^+^ valuu 167 | in if magnitude (newval ^-^ val) < tol then 168 | newval 169 | else 170 | evalSquare (tol/2) (level+1) maxlevel field (Surface f s_l s_m t_l t_m) 171 | surfll surflm surfml surfmm fieldll fieldlm fieldml fieldmm valll ^+^ 172 | evalSquare (tol/2) (level+1) maxlevel field (Surface f s_l s_m t_m t_u) 173 | surflm surflu surfmm surfmu fieldlm fieldlu fieldmm fieldmu vallu ^+^ 174 | evalSquare (tol/2) (level+1) maxlevel field (Surface f s_m s_u t_l t_m) 175 | surfml surfmm surful surfum fieldml fieldmm fieldul fieldum valul ^+^ 176 | evalSquare (tol/2) (level+1) maxlevel field (Surface f s_m s_u t_m t_u) 177 | surfmm surfmu surfum surfuu fieldmm fieldmu fieldum fielduu valuu 178 | -} 179 | 180 | {- 181 | dottedSurfIntegral :: Double 182 | -> (Vec -> Vec) -> Surface 183 | -> Double 184 | dottedSurfIntegral tol vf (Surface f s_l s_u t_l t_u) 185 | = let surfll = f (s_l,t_l s_l) 186 | surflu = f (s_l,t_u s_l) 187 | surful = f (s_u,t_l s_u) 188 | surfuu = f (s_u,t_u s_u) 189 | fieldll = vf surfll 190 | fieldlu = vf surflu 191 | fieldul = vf surful 192 | fielduu = vf surfuu 193 | du = surful ^-^ surfll 194 | dv = surflu ^-^ surfll 195 | area = du >< dv 196 | val = average [fieldll,fieldlu,fieldul,fielduu] <.> area 197 | in evalSquare tol 1 2 20 vf (Surface f s_l s_u t_l t_u) 198 | surfll surflu surful surfuu fieldll fieldlu fieldul fielduu val 199 | 200 | fullDottedSurfIntegral :: Double -> Int -> Int 201 | -> (Vec -> Vec) -> Surface 202 | -> Double 203 | fullDottedSurfIntegral tol minlevel maxlevel vf (Surface f s_l s_u t_l t_u) 204 | = let surfll = f (s_l,t_l s_l) 205 | surflu = f (s_l,t_u s_l) 206 | surful = f (s_u,t_l s_u) 207 | surfuu = f (s_u,t_u s_u) 208 | fieldll = vf surfll 209 | fieldlu = vf surflu 210 | fieldul = vf surful 211 | fielduu = vf surfuu 212 | du = surful ^-^ surfll 213 | dv = surflu ^-^ surfll 214 | area = du >< dv 215 | val = average [fieldll,fieldlu,fieldul,fielduu] <.> area 216 | in evalSquare tol 1 minlevel maxlevel vf (Surface f s_l s_u t_l t_u) 217 | surfll surflu surful surfuu fieldll fieldlu fieldul fielduu val 218 | 219 | evalSquare :: Double -> Int -> Int -> Int 220 | -> (Vec -> Vec) -> Surface 221 | -> Vec -> Vec -> Vec -> Vec 222 | -> Vec -> Vec -> Vec -> Vec -> Double -> Double 223 | evalSquare tol level minlevel maxlevel field (Surface f s_l s_u t_l t_u) 224 | surfll surflu surful surfuu fieldll fieldlu fieldul fielduu val 225 | = let s_m = (s_l + s_u) / 2 226 | t_m s = (t_l s + t_u s) / 2 227 | surflm = f (s_l,t_m s_l) 228 | surfum = f (s_u,t_m s_u) 229 | surfml = f (s_m,t_l s_m) 230 | surfmu = f (s_m,t_u s_m) 231 | surfmm = f (s_m,t_m s_m) 232 | fieldlm = field surflm 233 | fieldum = field surfum 234 | fieldml = field surfml 235 | fieldmu = field surfmu 236 | fieldmm = field surfmm 237 | dull = surfml ^-^ surfll 238 | dulu = surfmm ^-^ surflm 239 | duul = surful ^-^ surfml 240 | duuu = surfum ^-^ surfmm 241 | dvll = surflm ^-^ surfll 242 | dvlu = surflu ^-^ surflm 243 | dvul = surfmm ^-^ surfml 244 | dvuu = surfmu ^-^ surfmm 245 | areall = dull >< dvll 246 | arealu = dulu >< dvlu 247 | areaul = duul >< dvul 248 | areauu = duuu >< dvuu 249 | valll = average [fieldll,fieldlm,fieldml,fieldmm] <.> areall 250 | vallu = average [fieldlm,fieldlu,fieldmm,fieldmu] <.> arealu 251 | valul = average [fieldml,fieldmm,fieldul,fieldum] <.> areaul 252 | valuu = average [fieldmm,fieldmu,fieldum,fielduu] <.> areauu 253 | newval = valll + vallu + valul + valuu 254 | in if level >= maxlevel || level >= minlevel && abs (newval - val) < tol then 255 | newval 256 | else 257 | evalSquare (tol/4) (level+1) minlevel maxlevel field (Surface f s_l s_m t_l t_m) 258 | surfll surflm surfml surfmm fieldll fieldlm fieldml fieldmm valll + 259 | evalSquare (tol/4) (level+1) minlevel maxlevel field (Surface f s_l s_m t_m t_u) 260 | surflm surflu surfmm surfmu fieldlm fieldlu fieldmm fieldmu vallu + 261 | evalSquare (tol/4) (level+1) minlevel maxlevel field (Surface f s_m s_u t_l t_m) 262 | surfml surfmm surful surfum fieldml fieldmm fieldul fieldum valul + 263 | evalSquare (tol/4) (level+1) minlevel maxlevel field (Surface f s_m s_u t_m t_u) 264 | surfmm surfmu surfum surfuu fieldmm fieldmu fieldum fielduu valuu 265 | -} 266 | 267 | -- n+1 points 268 | linSpaced :: Int -> Double -> Double -> [Double] 269 | linSpaced n a b 270 | | a < b = let dx = (b - a) / fromIntegral n 271 | in [a,a+dx..b] 272 | | a ~~ b = [ave a b] 273 | | otherwise = error $ "linSpaced: lower limit greater than upper limit: (n,a,b) = " ++ show (n,a,b) 274 | 275 | (~~) :: (InnerSpace v, Scalar v ~ Double) => v -> v -> Bool 276 | a ~~ b = magnitude (a ^-^ b) < tolerance 277 | 278 | tolerance :: Double 279 | tolerance = 1e-10 280 | 281 | ave :: (VectorSpace v, Scalar v ~ Double) => v -> v -> v 282 | ave v1 v2 = (v1 ^+^ v2) ^/ 2 283 | 284 | {- 285 | average :: (VectorSpace v, Scalar v ~ Double) => [v] -> v 286 | average vs = sumV vs ^/ fromIntegral (length vs) 287 | 288 | areaOfSurface :: Surface -> Double 289 | areaOfSurface = surfaceIntegral 100 100 (const 1) 290 | -} 291 | 292 | -- | Shift a surface by a displacement. 293 | shiftSurface :: Displacement -> Surface -> Surface 294 | shiftSurface d (Surface f sl su tl tu) 295 | = Surface (shiftPosition d . f) sl su tl tu 296 | -------------------------------------------------------------------------------- /src/Physics/Learn/Visual/GlossTools.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | -- | Some tools related to the gloss 2D graphics and animation library. 4 | 5 | module Physics.Learn.Visual.GlossTools 6 | ( polarToCart 7 | , cartToPolar 8 | , arrow 9 | , thickArrow 10 | ) 11 | where 12 | 13 | import Graphics.Gloss 14 | import Graphics.Gloss.Geometry.Angle 15 | 16 | -- positive x is to the right in Translate 17 | -- positive y is up in Translate (this is good) 18 | 19 | basicArrow100 :: Picture 20 | basicArrow100 = Pictures [Line [(0,0),(100,0)],Polygon [(75,5),(100,0),(75,-5)]] 21 | 22 | -- | assumes radians coming in 23 | polarToCart :: (Float,Float) -> (Float,Float) 24 | polarToCart (r,theta) = (r * cos theta,r * sin theta) 25 | 26 | -- | theta=0 is positive x axis, 27 | -- output angle in radians 28 | cartToPolar :: (Float,Float) -> (Float,Float) 29 | cartToPolar (x,y) = (sqrt (x**2+y**2),atan2 y x) 30 | 31 | -- | An arrow 32 | arrow :: Point -- ^ location of base of arrow 33 | -> Point -- ^ displacement vector 34 | -> Picture 35 | arrow (x,y) val = Translate x y $ originArrow val 36 | 37 | -- | Rotate takes its angle in degrees, and rotates clockwise. 38 | originArrow :: Point -- ^ displacement vector 39 | -> Picture 40 | originArrow (x,y) 41 | = Rotate (-radToDeg theta) $ Scale (r/100) (r/100) basicArrow100 42 | where 43 | (r,theta) = cartToPolar (x,y) 44 | 45 | basicThickArrow :: Float -> Float -> Float -> Float -> Picture 46 | basicThickArrow l w headLength headWidth 47 | = Pictures [Polygon [(0,w/2),(l-hl,w/2),(l-hl,-w/2),(0,-w/2)] 48 | ,Polygon [(l-hl,hw/2),(l,0),(l-hl,-hw/2)] 49 | ] 50 | where 51 | hl = min l headLength 52 | hw = max w headWidth 53 | 54 | -- | A think arrow 55 | thickArrow :: Float -- ^ arrow thickness 56 | -> Point -- ^ location of base of arrow 57 | -> Point -- ^ displacement vector 58 | -> Picture 59 | thickArrow t (x,y) disp 60 | = Translate x y $ Rotate (-radToDeg theta) $ basicThickArrow r t (r/4) (2*t) 61 | where 62 | (r,theta) = cartToPolar disp 63 | 64 | -------------------------------------------------------------------------------- /src/Physics/Learn/Visual/PlotTools.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | {- | 4 | Module : Physics.Learn.Visual.PlotTools 5 | Copyright : (c) Scott N. Walck 2011-2014 6 | License : BSD3 (see LICENSE) 7 | Maintainer : Scott N. Walck 8 | Stability : experimental 9 | 10 | This module contains helping functions for using Gnuplot. 11 | -} 12 | 13 | module Physics.Learn.Visual.PlotTools 14 | ( label 15 | , postscript 16 | , psFile 17 | , examplePlot1 18 | , examplePlot2 19 | , plotXYCurve 20 | ) 21 | where 22 | 23 | import Graphics.Gnuplot.Simple 24 | ( Attribute(..) 25 | , plotFunc 26 | , plotPath 27 | ) 28 | import Physics.Learn.Curve 29 | ( Curve(..) 30 | ) 31 | import Physics.Learn.Position 32 | ( cartesianCoordinates 33 | ) 34 | 35 | -- | An 'Attribute' with a given label at a given position. 36 | label :: String -> (Double,Double) -> Attribute 37 | label name (x,y) 38 | = Custom "label" [show name ++ " at " ++ show x ++ "," ++ show y] 39 | 40 | -- | An 'Attribute' that requests postscript output. 41 | postscript :: Attribute 42 | postscript = Custom "term" ["postscript"] 43 | 44 | -- | An 'Attribute' giving the postscript file name. 45 | psFile :: FilePath -> Attribute 46 | psFile file = Custom "output" [show file] 47 | 48 | -- | An example of the use of 'label'. See the source code. 49 | examplePlot1 :: IO () 50 | examplePlot1 = plotFunc [Title "Cosine Wave" 51 | ,XLabel "Time (ms)" 52 | ,YLabel "Velocity" 53 | ,label "Albert Einstein" (2,0.8) 54 | ] [0,0.01..10::Double] cos 55 | 56 | -- | An example of the use of 'postscript' and 'psFile'. See the source code. 57 | examplePlot2 :: IO () 58 | examplePlot2 = plotFunc [Title "Cosine Wave" 59 | ,XLabel "Time (ms)" 60 | ,YLabel "Velocity of Car" 61 | ,label "Albert Einstein" (2,0.8) 62 | ,postscript 63 | ,psFile "post1.ps" 64 | ] [0,0.01..10::Double] cos 65 | 66 | -- | Plot a Curve in the xy plane using Gnuplot 67 | plotXYCurve :: Curve -> IO () 68 | plotXYCurve (Curve f a b) 69 | = plotPath [] [(x,y) | t <- [a,a+dt..b] 70 | , let (x,y,_) = cartesianCoordinates (f t)] 71 | where 72 | dt = (b-a)/1000 73 | -------------------------------------------------------------------------------- /src/Physics/Learn/Visual/VisTools.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | 3 | -- | Some tools related to the not-gloss 3D graphics and animation library. 4 | 5 | module Physics.Learn.Visual.VisTools 6 | ( v3FromVec 7 | , v3FromPos 8 | , visVec 9 | , oneVector 10 | , displayVectorField 11 | , curveObject 12 | ) 13 | where 14 | 15 | import SpatialMath 16 | ( V3(..) 17 | , Euler(..) 18 | ) 19 | import Vis 20 | ( VisObject(..) 21 | , Color 22 | ) 23 | import Physics.Learn.CarrotVec 24 | ( Vec 25 | , xComp 26 | , yComp 27 | , zComp 28 | -- , magnitude 29 | , (^/) 30 | ) 31 | import Physics.Learn.Position 32 | ( Position 33 | , cartesianCoordinates 34 | , VectorField 35 | ) 36 | import Physics.Learn.Curve 37 | ( Curve(..) 38 | ) 39 | 40 | -- | Make a 'V3' object from a 'Vec'. 41 | v3FromVec :: Vec -> V3 Double 42 | v3FromVec v = V3 x y z 43 | where 44 | x = xComp v 45 | y = yComp v 46 | z = zComp v 47 | 48 | -- | Make a 'V3' object from a 'Position'. 49 | v3FromPos :: Position -> V3 Double 50 | v3FromPos r = V3 x y z 51 | where 52 | (x,y,z) = cartesianCoordinates r 53 | 54 | -- | Display a vector field. 55 | displayVectorField :: Color -- ^ color for the vector field 56 | -> Double -- ^ scale factor 57 | -> [Position] -- ^ list of positions to show the field 58 | -> VectorField -- ^ vector field to display 59 | -> VisObject Double -- ^ the displayable object 60 | displayVectorField col unitsPerMeter samplePts field 61 | = VisObjects [Trans (v3FromPos r) $ visVec col (e ^/ unitsPerMeter) | r <- samplePts, let e = field r] 62 | 63 | -- | A displayable VisObject for a curve. 64 | curveObject :: Color -> Curve -> VisObject Double 65 | curveObject color (Curve f a b) 66 | = Line' Nothing [(v3FromPos (f t), color) | t <- [a,a+(b-a)/1000..b]] 67 | 68 | -- | Place a vector at a particular position. 69 | oneVector :: Color -> Position -> Vec -> VisObject Double 70 | oneVector c r v = Trans (v3FromPos r) $ visVec c v 71 | 72 | data Cart = Cart Double Double Double 73 | deriving (Show) 74 | 75 | data Sph = Sph Double Double Double 76 | deriving (Show) 77 | 78 | sphericalCoords :: Cart -> Sph 79 | sphericalCoords (Cart x y z) = Sph r theta phi 80 | where 81 | r = sqrt (x*x + y*y + z*z) 82 | s = sqrt (x*x + y*y) 83 | theta = atan2 s z 84 | phi = atan2 y x 85 | 86 | -- | A VisObject arrow from a vector 87 | visVec :: Color -> Vec -> VisObject Double 88 | visVec c v = rotZ phi $ rotY theta $ Arrow (r,20*r) (V3 0 0 1) c 89 | where 90 | x = xComp v 91 | y = yComp v 92 | z = zComp v 93 | Sph r theta phi = sphericalCoords (Cart x y z) 94 | 95 | {- 96 | rotX :: Double -- ^ in radians 97 | -> VisObject Double 98 | -> VisObject Double 99 | rotX alpha = RotEulerRad (Euler 0 0 alpha) 100 | -} 101 | 102 | rotY :: Double -- ^ in radians 103 | -> VisObject Double 104 | -> VisObject Double 105 | rotY alpha = RotEulerRad (Euler 0 alpha 0) 106 | 107 | rotZ :: Double -- ^ in radians 108 | -> VisObject Double 109 | -> VisObject Double 110 | rotZ alpha = RotEulerRad (Euler alpha 0 0) 111 | 112 | 113 | {- 114 | adjacentDistance :: [Position] -> Double 115 | adjacentDistance [] = 0 116 | adjacentDistance rs'@(_:rs) = minimum (map magnitude $ zipWith displacement rs' rs) 117 | 118 | visVectorField :: Color -> [Position] -> VectorField -> VisObject Double 119 | visVectorField c rs vf = let prs = [(r,vf r) | r <- rs] 120 | bigV = maximum [magnitude (snd pr) | pr <- prs] 121 | disp = adjacentDistance rs 122 | scaleFactor = disp / bigV 123 | newPrs = [(r, scaleFactor *^ v) | (r,v) <- prs] 124 | vecs = [oneVector c r v' | (r,v') <- newPrs] 125 | in VisObjects vecs 126 | -} 127 | -------------------------------------------------------------------------------- /src/Physics/Learn/Volume.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# OPTIONS_GHC -Wall #-} 3 | {-# LANGUAGE Safe #-} 4 | 5 | {- | 6 | Module : Physics.Learn.Volume 7 | Copyright : (c) Scott N. Walck 2012-2019 8 | License : BSD3 (see LICENSE) 9 | Maintainer : Scott N. Walck 10 | Stability : experimental 11 | 12 | This module contains functions for working with 'Volume's 13 | and volume integrals over 'Volume's. 14 | -} 15 | 16 | module Physics.Learn.Volume 17 | ( 18 | -- * Volumes 19 | Volume(..) 20 | , unitBall 21 | , unitBallCartesian 22 | , centeredBall 23 | , ball 24 | , northernHalfBall 25 | , centeredCylinder 26 | , shiftVolume 27 | -- * Volume Integral 28 | , volumeIntegral 29 | ) 30 | where 31 | 32 | import Data.VectorSpace 33 | ( VectorSpace 34 | , InnerSpace 35 | , Scalar 36 | ) 37 | import Physics.Learn.CarrotVec 38 | ( Vec 39 | , vec 40 | , sumV 41 | , (^+^) 42 | , (^-^) 43 | , (^*) 44 | , (^/) 45 | , (<.>) 46 | , (><) 47 | , magnitude 48 | ) 49 | import Physics.Learn.Position 50 | ( Position 51 | , Displacement 52 | , Field 53 | , cartesian 54 | , cylindrical 55 | , spherical 56 | , shiftPosition 57 | , displacement 58 | ) 59 | 60 | -- | Volume is a parametrized function from three parameters to space, 61 | -- lower and upper limits on the first parameter, 62 | -- lower and upper limits for the second parameter 63 | -- (expressed as functions of the first parameter), 64 | -- and lower and upper limits for the third parameter 65 | -- (expressed as functions of the first and second parameters). 66 | data Volume = Volume { volumeFunc :: (Double,Double,Double) -> Position -- ^ function from 3 parameters to space 67 | , loLimit :: Double -- ^ s_a 68 | , upLimit :: Double -- ^ s_b 69 | , loCurve :: Double -> Double -- ^ t_a(s) 70 | , upCurve :: Double -> Double -- ^ t_b(s) 71 | , loSurf :: Double -> Double -> Double -- ^ u_a(s,t) 72 | , upSurf :: Double -> Double -> Double -- ^ u_b(s,t) 73 | } 74 | 75 | -- | A unit ball, centered at the origin. 76 | unitBall :: Volume 77 | unitBall = Volume spherical 0 1 (const 0) (const pi) (\_ _ -> 0) (\_ _ -> 2*pi) 78 | 79 | -- | A unit ball, centered at the origin. Specified in Cartesian coordinates. 80 | unitBallCartesian :: Volume 81 | unitBallCartesian = Volume cartesian (-1) 1 (\x -> -sqrtTol (1 - x*x)) (\x -> sqrtTol (1 - x*x)) 82 | (\x y -> -sqrtTol (1 - x*x - y*y)) (\x y -> sqrtTol (1 - x*x - y*y)) 83 | 84 | -- | A ball with given radius, centered at the origin. 85 | centeredBall :: Double -> Volume 86 | centeredBall a = Volume spherical 0 a (const 0) (const pi) (\_ _ -> 0) (\_ _ -> 2*pi) 87 | 88 | -- | Ball with given radius and center. 89 | ball :: Double -- ^ radius 90 | -> Position -- ^ center 91 | -> Volume -- ^ ball with given radius and center 92 | ball a c = Volume (\(r,th,phi) -> shiftPosition (vec (r * sin th * cos phi) (r * sin th * sin phi) (r * cos th)) c) 93 | 0 a (const 0) (const pi) (\_ _ -> 0) (\_ _ -> 2*pi) 94 | 95 | -- | Upper half ball, unit radius, centered at origin. 96 | northernHalfBall :: Volume 97 | northernHalfBall = Volume spherical 0 1 (const 0) (const (pi/2)) (\_ _ -> 0) (\_ _ -> 2*pi) 98 | 99 | -- | Cylinder with given radius and height. Circular base of the cylinder 100 | -- is centered at the origin. Circular top of the cylinder lies in plane z = h. 101 | centeredCylinder :: Double -- radius 102 | -> Double -- height 103 | -> Volume -- cylinder 104 | centeredCylinder r h = Volume cylindrical 0 r (const 0) (const (2*pi)) (\_ _ -> 0) (\_ _ -> h) 105 | 106 | -- | A volume integral 107 | volumeIntegral :: (VectorSpace v, Scalar v ~ Double) => 108 | Int -- ^ number of intervals for first parameter (s) 109 | -> Int -- ^ number of intervals for second parameter (t) 110 | -> Int -- ^ number of intervals for third parameter (u) 111 | -> Field v -- ^ scalar or vector field 112 | -> Volume -- ^ the volume 113 | -> v -- ^ scalar or vector result 114 | volumeIntegral n1 n2 n3 field (Volume f s_l s_u t_l t_u u_l u_u) 115 | = sumV $ map sumV $ map (map sumV) (zipCubeWith (^*) aveVals volumes) 116 | where 117 | pts = [[[f (s,t,u) | u <- linSpaced n3 (u_l s t) (u_u s t) ] | t <- linSpaced n2 (t_l s) (t_u s)] | s <- linSpaced n1 s_l s_u] 118 | volumes = zipWith3 (zipWith3 (zipWith3 (\du dv dw -> du <.> (dv >< dw)))) dus dvs dws 119 | dus = uncurry zipSub3 (shift1 pts) 120 | dvs = uncurry zipSub3 (shift2 pts) 121 | dws = uncurry zipSub3 (shift3 pts) 122 | vals = map (map (map field)) pts 123 | aveVals = ((uncurry zipAve3 . shift1) . (uncurry zipAve3 . shift2) . (uncurry zipAve3 . shift3)) vals 124 | 125 | -- zipSquareWith :: (a -> b -> c) -> [[a]] -> [[b]] -> [[c]] 126 | -- zipSquareWith = zipWith . zipWith 127 | 128 | zipCubeWith :: (a -> b -> c) -> [[[a]]] -> [[[b]]] -> [[[c]]] 129 | zipCubeWith = zipWith . zipWith . zipWith 130 | 131 | -- zipSub :: [Vec] -> [Vec] -> [Vec] 132 | -- zipSub = zipWith (^-^) 133 | 134 | -- zipSub2 :: [[Vec]] -> [[Vec]] -> [[Vec]] 135 | -- zipSub2 = zipWith $ zipWith (^-^) 136 | 137 | zipSub3 :: [[[Position]]] -> [[[Position]]] -> [[[Vec]]] 138 | zipSub3 = zipCubeWith displacement 139 | 140 | zipAve3 :: (VectorSpace v, Scalar v ~ Double) => [[[v]]] -> [[[v]]] -> [[[v]]] 141 | zipAve3 = zipCubeWith ave 142 | 143 | shift1 :: [a] -> ([a],[a]) 144 | shift1 pts = (pts, tail pts) 145 | 146 | shift2 :: [[a]] -> ([[a]],[[a]]) 147 | shift2 pts2d = (pts2d, map tail pts2d) 148 | 149 | shift3 :: [[[a]]] -> ([[[a]]],[[[a]]]) 150 | shift3 pts3d = (pts3d, map (map tail) pts3d) 151 | 152 | -- | n+1 points 153 | linSpaced :: Int -> Double -> Double -> [Double] 154 | linSpaced n a b 155 | | a < b = let dx = (b - a) / fromIntegral n 156 | in [a,a+dx..b] 157 | | a ~~ b = [ave a b] 158 | | otherwise = error $ "linSpaced: lower limit greater than upper limit: (n,a,b) = " ++ show (n,a,b) 159 | 160 | (~~) :: (InnerSpace v, Scalar v ~ Double) => v -> v -> Bool 161 | a ~~ b = magnitude (a ^-^ b) < tolerance 162 | 163 | tolerance :: Double 164 | tolerance = 1e-10 165 | 166 | ave :: (VectorSpace v, Scalar v ~ Double) => v -> v -> v 167 | ave v1 v2 = (v1 ^+^ v2) ^/ 2 168 | 169 | sqrtTol :: Double -> Double 170 | sqrtTol x 171 | | x >= 0 = sqrt x 172 | | abs x <= tolerance = 0 173 | | otherwise = error ("sqrtTol: I can't take the sqrt of " ++ show x) 174 | 175 | -- | Shift a volume by a displacement. 176 | shiftVolume :: Displacement -> Volume -> Volume 177 | shiftVolume d (Volume f sl su tl tu ul uu) 178 | = Volume (shiftPosition d . f) sl su tl tu ul uu 179 | --------------------------------------------------------------------------------