mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-15 12:15:09 +09:00
Transitive reduction of DAGs in SQL
This commit is contained in:
fr33domlover
parent
c340508385
commit
8c1d4dd6f1
1 changed files with 182 additions and 0 deletions
|
|
@ -81,6 +81,9 @@ module Database.Persist.Local.Sql
|
||||||
, rmpath
|
, rmpath
|
||||||
, rpathm
|
, rpathm
|
||||||
, rmpathm
|
, rmpathm
|
||||||
|
-- * Transitive reduction of DAGs
|
||||||
|
, trrSelect
|
||||||
|
, trrApply
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
|
@ -88,6 +91,7 @@ import Prelude
|
||||||
|
|
||||||
import Control.Monad.IO.Class (MonadIO)
|
import Control.Monad.IO.Class (MonadIO)
|
||||||
import Control.Monad.Trans.Reader (ReaderT, ask)
|
import Control.Monad.Trans.Reader (ReaderT, ask)
|
||||||
|
import Data.Int (Int64)
|
||||||
import Data.Monoid ((<>))
|
import Data.Monoid ((<>))
|
||||||
import Data.Proxy (Proxy)
|
import Data.Proxy (Proxy)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
|
@ -1322,3 +1326,181 @@ rmpathm
|
||||||
-> Proxy (node, edge)
|
-> Proxy (node, edge)
|
||||||
-> ReaderT SqlBackend m [[Key node]]
|
-> ReaderT SqlBackend m [[Key node]]
|
||||||
rmpathm = xmpathm FollowBackward []
|
rmpathm = xmpathm FollowBackward []
|
||||||
|
|
||||||
|
-- | It more-or-less looks like this:
|
||||||
|
--
|
||||||
|
-- > WITH RECURSIVE
|
||||||
|
-- > temp (id, path, cycle) AS (
|
||||||
|
-- > SELECT node.id, ARRAY[node.id], FALSE
|
||||||
|
-- > FROM node
|
||||||
|
-- > UNION ALL
|
||||||
|
-- > SELECT edge.dest,
|
||||||
|
-- > temp.path || edge.dest,
|
||||||
|
-- > edge.dest = ANY(temp.path)
|
||||||
|
-- > FROM edge INNER JOIN temp
|
||||||
|
-- > ON edge.source = temp.id
|
||||||
|
-- > WHERE NOT temp.cycle
|
||||||
|
-- > )
|
||||||
|
-- > SELECT *
|
||||||
|
-- > FROM edge
|
||||||
|
-- >
|
||||||
|
-- > EXCEPT
|
||||||
|
-- >
|
||||||
|
-- > SELECT e.*
|
||||||
|
-- > FROM edge AS pre
|
||||||
|
-- > INNER JOIN temp ON pre.dest = temp.path[1]
|
||||||
|
-- > INNER JOIN edge AS e ON e.source = pre.source AND e.dest = temp.id
|
||||||
|
-- > WHERE NOT temp.cycle
|
||||||
|
trrSelect
|
||||||
|
:: ( MonadIO m
|
||||||
|
, PersistEntityGraph node edge
|
||||||
|
, SqlBackend ~ PersistEntityBackend node
|
||||||
|
, SqlBackend ~ PersistEntityBackend edge
|
||||||
|
)
|
||||||
|
=> Proxy (node, edge)
|
||||||
|
-> ReaderT SqlBackend m [Entity edge]
|
||||||
|
trrSelect proxy = do
|
||||||
|
conn <- ask
|
||||||
|
let tNode = entityDef $ dummyFromFst proxy
|
||||||
|
tEdge = entityDef $ dummyFromSnd proxy
|
||||||
|
fwd = persistFieldDef $ destFieldFromProxy proxy
|
||||||
|
bwd = persistFieldDef $ sourceFieldFromProxy proxy
|
||||||
|
temp = DBName "temp_hierarchy_cte"
|
||||||
|
tid = DBName "id"
|
||||||
|
tpath = DBName "path"
|
||||||
|
tcycle = DBName "cycle"
|
||||||
|
edgeP = DBName "pre"
|
||||||
|
edgeE = DBName "e"
|
||||||
|
dbname = connEscapeName conn
|
||||||
|
ecols = T.intercalate ", " $ entityColumnNames tEdge conn
|
||||||
|
qecols name =
|
||||||
|
T.intercalate ", " $
|
||||||
|
map ((dbname name <>) . ("." <>)) $
|
||||||
|
entityColumnNames tEdge conn
|
||||||
|
t ^* f = dbname t <> "." <> dbname f
|
||||||
|
t <#> s = dbname t <> " INNER JOIN " <> dbname s
|
||||||
|
t <# s = dbname t <> " LEFT OUTER JOIN " <> dbname s
|
||||||
|
|
||||||
|
sqlStep forward backward = mconcat
|
||||||
|
[ "SELECT "
|
||||||
|
, entityDB tEdge ^* fieldDB forward, ", "
|
||||||
|
, temp ^* tpath, " || ", entityDB tEdge ^* fieldDB forward, ", "
|
||||||
|
, entityDB tEdge ^* fieldDB forward, " = ANY(", temp ^* tpath, ")"
|
||||||
|
, " FROM ", entityDB tEdge <#> temp
|
||||||
|
, " ON ", entityDB tEdge ^* fieldDB backward, " = ", temp ^* tid
|
||||||
|
, " WHERE NOT " <> temp ^* tcycle
|
||||||
|
]
|
||||||
|
|
||||||
|
sql = mconcat
|
||||||
|
[ "WITH RECURSIVE "
|
||||||
|
, dbname temp
|
||||||
|
, " ("
|
||||||
|
, T.intercalate "," $ map dbname [tid, tpath, tcycle]
|
||||||
|
, ") AS ( SELECT "
|
||||||
|
, entityDB tNode ^* fieldDB (entityId tNode), ", "
|
||||||
|
, "ARRAY[", entityDB tNode ^* fieldDB (entityId tNode), "], "
|
||||||
|
, "FALSE"
|
||||||
|
, " FROM ", dbname $ entityDB tNode
|
||||||
|
, " WHERE ", entityDB tNode ^* fieldDB (entityId tNode)
|
||||||
|
, " IN ?"
|
||||||
|
, " UNION ALL "
|
||||||
|
, sqlStep fwd bwd
|
||||||
|
, " )"
|
||||||
|
, " SELECT ", ecols
|
||||||
|
, " FROM ", dbname $ entityDB tEdge
|
||||||
|
, " EXCEPT "
|
||||||
|
, " SELECT ", qecols edgeE
|
||||||
|
, " FROM ", dbname $ entityDB tEdge, " AS ", dbname edgeP
|
||||||
|
, " INNER JOIN ", dbname temp
|
||||||
|
, " ON ", edgeP ^* fieldDB fwd, " = ", temp ^* tpath, "[1]"
|
||||||
|
, " INNER JOIN ", dbname $ entityDB tEdge, " AS ", dbname edgeE
|
||||||
|
, " ON ", edgeE ^* fieldDB bwd, " = ", edgeP ^* fieldDB bwd
|
||||||
|
, " AND ", edgeE ^* fieldDB fwd, " = ", temp ^* tid
|
||||||
|
, " WHERE NOT ", temp ^* tcycle
|
||||||
|
]
|
||||||
|
rawSql sql []
|
||||||
|
|
||||||
|
-- | It more-or-less looks like this:
|
||||||
|
--
|
||||||
|
-- > WITH RECURSIVE
|
||||||
|
-- > temp (id, path, cycle) AS (
|
||||||
|
-- > SELECT node.id, ARRAY[node.id], FALSE
|
||||||
|
-- > FROM node
|
||||||
|
-- > UNION ALL
|
||||||
|
-- > SELECT edge.dest,
|
||||||
|
-- > temp.path || edge.dest,
|
||||||
|
-- > edge.dest = ANY(temp.path)
|
||||||
|
-- > FROM edge INNER JOIN temp
|
||||||
|
-- > ON edge.source = temp.id
|
||||||
|
-- > WHERE NOT temp.cycle
|
||||||
|
-- > )
|
||||||
|
-- > DELETE FROM edge
|
||||||
|
-- > WHERE id IN (
|
||||||
|
-- > SELECT e.id
|
||||||
|
-- > FROM edge AS pre
|
||||||
|
-- > INNER JOIN temp ON pre.dest = temp.path[1]
|
||||||
|
-- > INNER JOIN edge AS e ON e.source = pre.source AND e.dest = temp.id
|
||||||
|
-- > WHERE NOT temp.cycle
|
||||||
|
-- > )
|
||||||
|
trrApply
|
||||||
|
:: ( MonadIO m
|
||||||
|
, PersistEntityGraph node edge
|
||||||
|
, SqlBackend ~ PersistEntityBackend node
|
||||||
|
, SqlBackend ~ PersistEntityBackend edge
|
||||||
|
)
|
||||||
|
=> Proxy (node, edge)
|
||||||
|
-> ReaderT SqlBackend m Int64
|
||||||
|
trrApply proxy = do
|
||||||
|
conn <- ask
|
||||||
|
let tNode = entityDef $ dummyFromFst proxy
|
||||||
|
tEdge = entityDef $ dummyFromSnd proxy
|
||||||
|
fwd = persistFieldDef $ destFieldFromProxy proxy
|
||||||
|
bwd = persistFieldDef $ sourceFieldFromProxy proxy
|
||||||
|
temp = DBName "temp_hierarchy_cte"
|
||||||
|
tid = DBName "id"
|
||||||
|
tpath = DBName "path"
|
||||||
|
tcycle = DBName "cycle"
|
||||||
|
edgeP = DBName "pre"
|
||||||
|
edgeE = DBName "e"
|
||||||
|
dbname = connEscapeName conn
|
||||||
|
t ^* f = dbname t <> "." <> dbname f
|
||||||
|
t <#> s = dbname t <> " INNER JOIN " <> dbname s
|
||||||
|
t <# s = dbname t <> " LEFT OUTER JOIN " <> dbname s
|
||||||
|
|
||||||
|
sqlStep forward backward = mconcat
|
||||||
|
[ "SELECT "
|
||||||
|
, entityDB tEdge ^* fieldDB forward, ", "
|
||||||
|
, temp ^* tpath, " || ", entityDB tEdge ^* fieldDB forward, ", "
|
||||||
|
, entityDB tEdge ^* fieldDB forward, " = ANY(", temp ^* tpath, ")"
|
||||||
|
, " FROM ", entityDB tEdge <#> temp
|
||||||
|
, " ON ", entityDB tEdge ^* fieldDB backward, " = ", temp ^* tid
|
||||||
|
, " WHERE NOT " <> temp ^* tcycle
|
||||||
|
]
|
||||||
|
|
||||||
|
sql = mconcat
|
||||||
|
[ "WITH RECURSIVE "
|
||||||
|
, dbname temp
|
||||||
|
, " ("
|
||||||
|
, T.intercalate "," $ map dbname [tid, tpath, tcycle]
|
||||||
|
, ") AS ( SELECT "
|
||||||
|
, entityDB tNode ^* fieldDB (entityId tNode), ", "
|
||||||
|
, "ARRAY[", entityDB tNode ^* fieldDB (entityId tNode), "], "
|
||||||
|
, "FALSE"
|
||||||
|
, " FROM ", dbname $ entityDB tNode
|
||||||
|
, " WHERE ", entityDB tNode ^* fieldDB (entityId tNode)
|
||||||
|
, " IN ?"
|
||||||
|
, " UNION ALL "
|
||||||
|
, sqlStep fwd bwd
|
||||||
|
, " ) DELETE FROM ", dbname $ entityDB tEdge
|
||||||
|
, " WHERE ", entityDB tEdge ^* fieldDB (entityId tEdge), " IN ("
|
||||||
|
, " SELECT ", edgeE ^* fieldDB (entityId tEdge)
|
||||||
|
, " FROM ", dbname $ entityDB tEdge, " AS ", dbname edgeP
|
||||||
|
, " INNER JOIN ", dbname temp
|
||||||
|
, " ON ", edgeP ^* fieldDB fwd, " = ", temp ^* tpath, "[1]"
|
||||||
|
, " INNER JOIN ", dbname $ entityDB tEdge, " AS ", dbname edgeE
|
||||||
|
, " ON ", edgeE ^* fieldDB bwd, " = ", edgeP ^* fieldDB bwd
|
||||||
|
, " AND ", edgeE ^* fieldDB fwd, " = ", temp ^* tid
|
||||||
|
, " WHERE NOT ", temp ^* tcycle
|
||||||
|
, " )"
|
||||||
|
]
|
||||||
|
rawExecuteCount sql []
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue