Aelve Codesearch

grep over package repositories
Please provide a string to search for.
3+ characters are required.
Index updated 5 hours ago

total matches: more than 1000

ADPfusionForest-0.0.0.1
12 matches
src/AffineAlignNewickTreesSmall.hs
import           ADP.Fusion.Core
import           Biobase.Newick
import           Data.Forest.Static (TreeOrder(..),Forest)
import           Data.PrimitiveArray as PA hiding (map)
import qualified Diagrams.TwoD.ProbabilityGrid as PG
import           FormalLanguage.CFG
import qualified Data.Forest.Static as F

import           ADP.Fusion.Forest.Align.RL

            
src/AffineAlignNewickTreesSmall.hs
      f2 <- readFile n2
      runAlignS f1 f2 (round matchSc) (round notmatchSc) (round delinSc) (round affinSc)
      unless (null probFile) $ do
        runAlignIO (if linearScale then PG.FWlinear else PG.FWlog) probFileTy (probFile ++ "-" ++ takeBaseName n1 ++ "-" ++ takeBaseName n2 ++ "." ++ (map toLower $ show probFileTy)) f1 f2 (f matchSc) (f notmatchSc) (f delinSc) (f affinSc) (Exp temperature)


test n1 n2 = do
  f1 <- readFile n1
  f2 <- readFile n2

            
src/AffineAlignNewickTreesSmall.hs
{-# NoInline test #-}

runAlignS t1' t2' matchSc notmatchSc delinSc affinSc = do
  let f x = either error (F.forestPre . map getNewickTree) $ newicksFromText x
      t1 = f $ Text.pack t1'
      t2 = f $ Text.pack t2'
  let (fwd,sc,bt') = run t1 t2 matchSc notmatchSc delinSc affinSc
  let (Z:.TW (ITbl _ _ _ iet) _ :.TW (ITbl _ _ _ ift) _ :.TW (ITbl _ _ _ iqt) _ :.TW (ITbl _ _ _ irt) _ :.TW (ITbl _ _ _ itt) _ :.TW (ITbl _ _ _ ist) _ :.TW (ITbl _ _ _ izt) _) = fwd
  let bt = take 1 bt' -- nub bt'

            
src/AffineAlignNewickTreesSmall.hs
  printf "Score: %10d\n" sc
--  forM_ bt $ \b -> do
--    putStrLn ""
--    forM_ b $ \x -> putStrLn $ T.drawTree $ fmap show x
{-# NoInline runAlignS #-}

runAlignIO fw probFileTy probFile t1' t2' matchSc mismatchSc indelSc affinSc temperature = do
  let f x = either error (F.forestPre . map getNewickTree) $ newicksFromText x
      t1 = f $ Text.pack t1'
      t2 = f $ Text.pack t2'
  let (inn,out,_) = runIO t1 t2 matchSc mismatchSc indelSc affinSc temperature -- (t2 {F.lsib = VG.fromList [-1,-1], F.rsib = VG.fromList [-1,-1]})
  let (Z:.TW (ITbl _ _ _ iet) _ :.TW (ITbl _ _ _ ift) _ :.TW (ITbl _ _ _ iqt) _ :.TW (ITbl _ _ _ irt) _ :.TW (ITbl _ _ _ itt) _ :.TW (ITbl _ _ _ ist) _ :.TW (ITbl _ _ _ izt) _) = inn
  let (Z:.TW (ITbl _ _ _ iet) _ :.TW (ITbl _ _ _ oft) _ :.TW (ITbl _ _ _ oqt) _ :.TW (ITbl _ _ _ ort) _ :.TW (ITbl _ _ _ ott) _ :.TW (ITbl _ _ _ ost) _ :.TW (ITbl _ _ _ ozt) _) = out

            
src/AffineAlignNewickTreesSmall.hs
  let ix = (Z:.TreeIxR frst1 lb1 F:.TreeIxR frst2 lb2 F)
  let sc = ift ! ix
  print sc
  let ps = map (\(k,k1,k2) ->
            let k' = unsafeCoerce k
            in  ( k1
                , k2
                , ((itt!k) * (ott!k') / sc)
                , (maybe "-" label $ F.label t1 VG.!? k1)

            
src/AffineAlignNewickTreesSmall.hs
                , (maybe "-" label $ F.label t2 VG.!? k2)
                )) [ (Z:.TreeIxR frst1 k1 T:.TreeIxR frst2 k2 T,k1,k2) | k1 <- [lb1 .. ub1 - 1], k2 <- [lb2 .. ub2 - 1] ]
  --
  let gsc = map (\(k1,k2,sc,l1,l2) -> sc) ps
  let fillText [] = " "
      fillText xs = xs
  mapM_ print gsc
  let gl1 = map (\k1 -> fillText . Text.unpack $ (maybe "-" label $ F.label t1 VG.!? k1)) [lb1 .. ub1 - 1]
  let gl2 = map (\k2 -> fillText . Text.unpack $ (maybe "-" label $ F.label t2 VG.!? k2)) [lb2 .. ub2 - 1]
  case probFileTy of
         SVG -> PG.svgGridFile probFile fw PG.FSfull ub1 ub2 gl1 gl2 gsc
         EPS -> PG.epsGridFile probFile fw PG.FSfull ub1 ub2 gl1 gl2 gsc
{-# NoInline runAlignIO #-}


            
src/AlignNewickTrees.hs
import           ADP.Fusion.Core
import           Biobase.Newick
import           Data.Forest.Static (TreeOrder(..),Forest)
import           Data.PrimitiveArray as PA hiding (map)
import qualified Diagrams.TwoD.ProbabilityGrid as PG
import           FormalLanguage.CFG
import qualified Data.Forest.Static as F

import           ADP.Fusion.Forest.Align.RL

            
src/AlignNewickTrees.hs
      f2 <- readFile n2
      runAlignS f1 f2 (round matchSc) (round notmatchSc) (round delinSc)
      unless (null probFile) $ do
        runAlignIO (if linearScale then PG.FWlinear else PG.FWlog) probFileTy (probFile ++ "-" ++ takeBaseName n1 ++ "-" ++ takeBaseName n2 ++ "." ++ (map toLower $ show probFileTy)) f1 f2 (f matchSc) (f notmatchSc) (f delinSc) (Exp temperature)




runAlignS t1' t2' matchSc notmatchSc delinSc = do

            
src/AlignNewickTrees.hs


runAlignS t1' t2' matchSc notmatchSc delinSc = do
  let f x = either error (F.forestPre . map getNewickTree) $ newicksFromText x
      t1 = f $ Text.pack t1'
      t2 = f $ Text.pack t2'
  let (fwd,sc,bt') = runS t1 t2 matchSc notmatchSc delinSc
  let (Z:.TW (ITbl _ _ _ ift) _ :. TW (ITbl _ _ _ imt) _ :. TW (ITbl _ _ _ itt) _) = fwd
  let bt = take 1 bt' -- TODO make nice !!! nub bt'

            
src/AlignNewickTrees.hs
  printf "Score: %10d\n" sc
  forM_ bt $ \b -> do
    putStrLn ""
    forM_ b $ \x -> putStrLn $ T.drawTree $ fmap show x

runAlignIO fw probFileTy probFile t1' t2' matchSc mismatchSc indelSc temperature = do
  let f x = either error (F.forestPre . map getNewickTree) $ newicksFromText x
      t1 = f $ Text.pack t1'
      t2 = f $ Text.pack t2'
  let (inn,out,_) = runIO t1 t2 matchSc mismatchSc indelSc temperature -- (t2 {F.lsib = VG.fromList [-1,-1], F.rsib = VG.fromList [-1,-1]})
  let (Z:.TW (ITbl _ _ _ ift) _ :. TW (ITbl _ _ _ imt) _ :. TW (ITbl _ _ _ itt) _) = inn
  let (Z:.TW (ITbl _ _ _ oft) _ :. TW (ITbl _ _ _ omt) _ :. TW (ITbl _ _ _ ott) _) = out

            
src/AlignNewickTrees.hs
  print scimt
  let scomt = Prelude.sum [ omt ! (Z:.TreeIxR frst1 b1 T :. TreeIxR frst2 b2 T) | b1 <- [lb1 .. ub1], b2 <- [lb2 .. ub2] ]
  print scomt
  let ps = map (\(k,k1,k2) ->
            let k' = unsafeCoerce k
            in  ( k1
                , k2
                , ((imt!k) * (omt!k') / scift)
                , (maybe "-" label $ F.label t1 VG.!? k1)

            
src/AlignNewickTrees.hs
                , (maybe "-" label $ F.label t2 VG.!? k2)
                )) [ (Z:.TreeIxR frst1 k1 T:.TreeIxR frst2 k2 T,k1,k2) | k1 <- [lb1 .. ub1 - 1], k2 <- [lb2 .. ub2 - 1] ]
  --
  let gsc = map (\(k1,k2,sc,l1,l2) -> sc) ps
  let fillText [] = " "
      fillText xs = xs
  let gl1 = map (\k1 -> fillText . Text.unpack $ (maybe "-" label $ F.label t1 VG.!? k1)) [lb1 .. ub1 - 1]
  let gl2 = map (\k2 -> fillText . Text.unpack $ (maybe "-" label $ F.label t2 VG.!? k2)) [lb2 .. ub2 - 1]
  case probFileTy of
         SVG -> PG.svgGridFile probFile fw PG.FSfull ub1 ub2 gl1 gl2 gsc
         EPS -> PG.epsGridFile probFile fw PG.FSfull ub1 ub2 gl1 gl2 gsc


            
Advise-me-0.1
18 matches
app/DatabaseBuilder.hs
         )
#endif
      <*>
         ( fmap (fmap $ map trim . split ',') . O.optional . O.strOption $
            O.long "filter" <>
            O.help "Put requests in the given order; discard all others (expects comma-seperated list of task IDs)"
         )
      <*>
         ( O.switch $

            
app/DatabaseBuilder.hs
   let filterFlag = isJust . taskFilterArg
       taskFilter = fromMaybe [] $ taskFilterArg arg

   inConns <- mapM connectSqlite3 (inDBs arg)

   -- Test if a students table already exist
   (anyStudentsTable, allStudentsTable) <- do
      hasTable <- map ("students" `elem`) <$> mapM SQL.getTables inConns
      return (or hasTable, and hasTable)

   -- Check for nonsensical commands
   unless (smFlag arg `implies` (allStudentsTable || drFlag arg)) $
      error "Cannot run student modeller without evidence. Either run --evidence or make sure your input databases already contain students tables."

            
app/DatabaseBuilder.hs
#ifdef XLSX
   -- Write final models table
   let humanAssessments = writeHumanAssessmentTableFlag arg
   let allObserved = foldl (\m r -> M.insertWith mappend (r!"studentid",r!"taskid") (r ! "evidence") m) mempty records
   when (not $ null humanAssessments) $ do
      tallies <- forM humanAssessments $ \path -> do
         xlsx <- getSpreadsheet path
         tally' xlsx allObserved
      writeHumanAssessmentTable conn . mconcat . concat . map M.elems $ tallies

            
app/DatabaseBuilder.hs
      tallies <- forM humanAssessments $ \path -> do
         xlsx <- getSpreadsheet path
         tally' xlsx allObserved
      writeHumanAssessmentTable conn . mconcat . concat . map M.elems $ tallies
#endif

   -- Finalize
   SQL.commit conn
   SQL.disconnect conn

            
app/DatabaseBuilder.hs
   -- Finalize
   SQL.commit conn
   SQL.disconnect conn
   mapM_ SQL.disconnect inConns


-- | Auxiliary: List all possible task IDs.
taskIDs :: [String]
taskIDs = map showId tasks

            
app/DatabaseBuilder.hs

-- | Auxiliary: List all possible task IDs.
taskIDs :: [String]
taskIDs = map showId tasks


-- | Auxiliary: Logical material implication.
implies :: Bool -> Bool -> Bool
x `implies` y = not x || y

            
app/DatabaseBuilder.hs
   forM records $ \record ->
      let input = addCodepoints . fixEntities . T.unpack . T.decodeLatin1 . Char8.pack $ record ! "input"
      in do
         --mapM putChar (filter (\x -> not $ x == '\10' || x >= ' ' || x <= '~') input)
         return . insert "input" input $ record

   where
   -- | Temporary solution to solve issue #240 & #253. The issue was that
   -- parseXML expects a string without actual Unicode characters - not a

            
app/DatabaseBuilder.hs

   -- | Fix HTML entities DWO sent wrong. (see issue #242)
   fixEntities :: String -> String
   fixEntities = flip (foldr ($)) $ map (uncurry replace)
      [ ("&lt;;","&lt;") -- This is super hacky, but so is the problem itself
      , ("&lt","&lt;")
      ]



            
app/DatabaseBuilder.hs
-- | Add identifying information that is not logged by Ideas. Clearly, this is
-- not an ideal solution, but it will do for now.
decorateRequests :: [SqlRecord] -> IO [SqlRecord]
decorateRequests = mapM $ \record ->
   let  input = record ! "input"
        (sID,tID) = fromJust . collectIDs $ input
        iIDs = intercalate "," . map fst . fromJust . collectInputs $ input
        rID = range [record ! "rowid"]
   in return
         . insert "inputs" iIDs
         . insert "studentid" sID
         . insert "taskid" tID

            
app/DatabaseBuilder.hs
anonymize :: [SqlRecord] -> IO [SqlRecord]
anonymize records = 
   let translation :: M.Map String String
       translation = M.fromList $ zip (nub $ map (! "studentid") records) (map show [1..])
   in forM records $ \record -> do
      let sID' = translation M.! (record ! "studentid")
      return $ insert "studentid" sID'
             . insert "input" (setID sID' $ record ! "input")
             . insert "output" (setID sID' $ record ! "output")

            
app/DatabaseBuilder.hs

   where
   setID :: String -> XML.XML -> XML.XML
   setID sID = XML.foldXML (\t as cs -> XML.makeXML t . mconcat $ map (mkAttr' sID) as ++ map (either XML.string XML.builder) cs) id id

   mkAttr' :: String -> XML.Attribute -> XML.XMLBuilder
   mkAttr' sID ("userid" XML.:= _) = "userid" XML..=. sID
   mkAttr' sID ("user" XML.:= _) = "user" XML..=. sID
   mkAttr' sID (n XML.:= a) = n XML..=. a

            
app/DatabaseBuilder.hs
collapseRequests :: [SqlRecord] -> IO [SqlRecord]
collapseRequests records = do
   --forM records $ \record -> do
   --   mapM (\x -> putStrLn $ show x ++ show (fromEnum x)) (record ! "input" :: String)
   --   print $ XML.parseXML (record ! "input")
   -- Extract decorated records and reinsert the XML
   let collapsed = map (uncurry $ insert "input") . M.elems
                 -- Map student/task pairs to decorated records
                 . foldl' (\m e -> M.insertWith merger (getKey e) e m) M.empty
                 -- Decorate each record with its XML, to avoid re-parsing it on every merge
                 . map ((! "input") &&& id)
                 $ records
   putStrLn $ "Collapsed " ++ show (length records) ++ " records into " ++ show (length collapsed) ++ "."
   return collapsed

   where

            
app/DatabaseBuilder.hs
      new' <- collectInputs new
      old' <- collectInputs old
      return . replaceInputs new
             . map (Right . snd)
             . sortBy (compare `on` fst)
             . nubBy ((==) `on` fst)
             $ new' ++ old'

mkAttr (n XML.:= a) = n XML..=. a

            
app/DatabaseBuilder.hs
   where 

   mkXML :: XML.Name -> [XML.Attribute] -> [Either String XML.XML] -> XML.XML
   mkXML t as cs = XML.makeXML t . mconcat $ map mkAttr as ++ map (mkContent id) cs

   foldRequest "request" as cs = XML.makeXML "request" . mconcat $ map mkAttr as ++ map (mkContent $ XML.foldXML foldSolution id id) cs
   foldRequest t as cs = mkXML t as cs
   
   foldSolution "solution" as cs = XML.makeXML "solution" . mconcat $ map mkAttr as ++ map (mkContent id) inputs
   foldSolution t as cs = mkXML t as cs


-- | Trim requests that are empty or consist exclusively of whitespace.
trimEmptyRequests :: [SqlRecord] -> IO [SqlRecord]

            
app/DatabaseBuilder.hs
-- | Trim requests that are empty or consist exclusively of whitespace.
trimEmptyRequests :: [SqlRecord] -> IO [SqlRecord]
trimEmptyRequests records = do
   let trimmed = [ insert "input" (replaceInputs request $ map Right inputs') record
                 | record <- records
                 , let request = record ! "input"
                 , inputs <- map snd <$> collectInputs request
                 , let inputs' = filter (not . isEmpty . XML.content) inputs
                 , not (null inputs') ]
   putStrLn $ "Trimmed " ++ show (length records) ++ " records into " ++ show (length trimmed)
   return trimmed


            
app/DatabaseBuilder.hs
-- recognized beforehand is changed to the new number. Of course, this is far
-- from bulletproof,  but the data will be worth more than if we didn't do it.
changeNumbersInOldRequests :: [SqlRecord] -> IO [SqlRecord]
changeNumbersInOldRequests = return . map maybeChange

   where

   maybeChange :: SqlRecord -> SqlRecord
   maybeChange r | condition "carrental" "2019-01-01" r = adjust "input" carrental . adjust "original" (++"*") $ r

            
app/DatabaseBuilder.hs
         then return record
         else do
            (_, tID) <- collectIDs input
            inputs <- map snd <$> collectInputs input
            let inputs' = ($ inputs) $ stripv0 . 
                  case tID of
                     "makingasquare" -> transformIDs [("1","01")]
                     "matryoshka" -> transformIDs [("1","02")]
                     "carrental" -> transformIDs [("1","03")]

            
app/DatabaseBuilder.hs
                     "areaandexpression" -> fixMatrix
                     "areaofatriangle" -> transformIDs [("1","09a"), ("2","09b"),("3","09c")] . separate
                     "vpattern" -> transformIDs [("1","10")]
            let input' = replaceInputs input $ map Right inputs'
            return $ insert "input" input' record


   where