Yam Code

New Paste Browse

module Neck.Fingering (
  fingering,
  FingeringF,
  Fingering
) where

import Control.Monad.Reader

import Prelude
import Partial.Unsafe (unsafeCrashWith)
import Data.Argonaut.Decode
import Data.Array (catMaybes, foldM, index, mapMaybe, zipWith, (..), filter)
import Data.Foldable (intercalate, null, length)
import Data.FunctorWithIndex
import Data.Function (on)
import Data.Int (toNumber, ceil)
import Data.Maybe
import Data.Ring
import Data.Semigroup.Foldable (class Foldable1, foldMap1, fold1)
import Data.Traversable
import Data.Tuple

import Debug.Trace
import Neck.Fret
import Music.Transpose (class Transpose, trans)

newtype FingeringF a = Fingering
  { e4 :: a , b3 :: a , g3 :: a , d3 :: a , a2 :: a , e2 :: a }
instance eq_chord :: (Eq a) => Eq (FingeringF a) where
  eq = eq `on` toArray
instance ord_chord :: (Ord a) => Ord (FingeringF a) where
  compare = compare `on` toArray
instance functor_chord :: Functor FingeringF where
  map f (Fingering x) = fingeringf
    (f x.e4) (f x.b3) (f x.g3) (f x.d3) (f x.a2) (f x.e2)
instance functor_with_index_chord :: FunctorWithIndex Int FingeringF where
  mapWithIndex f (Fingering x) = fingeringf
    (f 0 x.e4) (f 1 x.b3) (f 2 x.g3) (f 3 x.d3) (f 4 x.a2) (f 5 x.e2)
instance apply_chord :: Apply FingeringF where
  apply (Fingering f) (Fingering x) = fingeringf
    (f.e4 x.e4) (f.b3 x.b3) (f.g3 x.g3) (f.d3 x.d3) (f.a2 x.a2) (f.e2 x.e2)
instance applicative_chord :: Applicative FingeringF where
  pure x = fingeringf x x x x x x
instance foldable_chord :: Foldable FingeringF where
  foldl f z chord = foldl f z $ toArray chord
  foldr f z chord = foldr f z $ toArray chord
  foldMap f chord = foldMap f $ toArray chord
instance traversable_chord :: Traversable FingeringF where
  traverse f (Fingering x) = fingeringf
    <$> f x.e4  <*> f x.b3 <*> f x.g3 <*> f x.d3 <*> f x.a2 <*> f x.e2
  sequence = traverse identity
instance foldable1_chord :: Foldable1 FingeringF where
  foldMap1 f (Fingering c) = f c.e4 <> f c.b3 <> f c.g3 <> f c.d3 <> f c.a2 <> f c.e2
  fold1 = foldMap1 identity

fingeringf :: forall a. a -> a -> a -> a -> a -> a -> FingeringF a
fingeringf e4 b3 g3 d3 a2 e2 = Fingering { e4, b3, g3, d3, a2, e2 }

type Fingering = FingeringF GuitarString
instance show_fingering :: Show (FingeringF GuitarString) where
  show = intercalate "-" <<< map (maybe "x" show <<< unfret) <<< toArray
instance transpose_fingering :: Transpose (FingeringF GuitarString) where
  trans n fing = normaliseFingering $ map (trans n) fing

fingering
  :: GuitarString
  -> GuitarString
  -> GuitarString
  -> GuitarString
  -> GuitarString
  -> GuitarString
  -> Fingering
fingering e4 b3 g3 d3 a2 e2 =
  if length (filter isFretted [e4, b3, g3, d3, a2, e2]) >= 1
    then fingeringf e4 b3 g3 d3 a2 e2
    else fingeringError

fingeringError :: forall a. a
fingeringError = unsafeCrashWith  "All fingerings must have have at least 1 note note (a zero note fingering is not really a fingering)"

{- The fret range of a fingering is the total span of the non-muted notes. -}
fretRange :: Fingering -> Tuple Int Int
fretRange fing = fromMaybe fingeringError (Tuple <$> minimum frets <*> maximum frets)
  where frets = catMaybes (map unfret $ toArray fing)

{-
  A fingering shifted 12 frets (1 octave) is essentially the same fingering. Normalisation shifts a fingering down by the maximum number of octaves, as long as there are no negative frets produced.

normaliseFingering "x-0-2-2-1-0" = "x-0-2-2-1-0"
  normaliseFingering "x-15-17-17-17-15" = "x-3-5-5-5-3"
-}
normaliseFingering :: Fingering -> Fingering
normaliseFingering fing = map (trans (12*octaveShift)) fing
  where
    octaveShift = ceil (- toNumber minFret / 12.0)
    minFret = fst $ fretRange fing

toArray :: FingeringF ~> Array
toArray (Fingering c) = [c.e4, c.b3, c.g3, c.d3, c.a2, c.e2]

{- A fingering is open if it contains at least one note freted at fret 0 -}
isOpen :: Fingering -> Boolean
isOpen = any $ case _ of
  Muted  -> false
  Fret n -> n == 0

{- A fingering is valid if all fretted notes are in the range [0, 24] -}
validFingering :: Fingering -> Boolean
validFingering = all $ case _ of
  Muted  -> true
  Fret n -> 0 <= n && n <= 24

Paste Settings

Paste Title : [Optional]

Paste Folder : [Optional]

Syntax Highlighting : [Optional]

Paste Expiration : [Optional]

Paste Status : [Optional]

Password : [Optional]

Description: [Optional]

Tags: [Optional]

Encrypt Paste (?)

You are currently not logged in, this means you can not edit or delete anything you paste. Sign Up or Login

Paste Settings

Site Languages