Skip to content

Instantly share code, notes, and snippets.

@achal7

achal7/gist:c2a076f3a5cc2e1ea74ddbf11f84c210

Created May 12, 2026 16:57
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save achal7/c2a076f3a5cc2e1ea74ddbf11f84c210 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save achal7/c2a076f3a5cc2e1ea74ddbf11f84c210 to your computer and use it in GitHub Desktop.
Download ZIP
SupplyChainMockup
Raw
gistfile1.txt
ConstraintAbstraction we needValues inside structureFunctorIndependent contextual valuesApplicativeDependent contextual stepsMonadEffectful functionsKleisli categoryCombining valuesMonoidTransforming between contextsNatural transformationConsuming valuesContravariant functorInput-output adaptationProfunctorRecursive interpretationF-algebra / catamorphismWorkflow descriptionFree structure / DSL
1. What are the input and output types?
2. Can this step fail?
3. Are checks independent or dependent?
4. Do we want error accumulation or fail-fast?
5. Does order matter?
6. What operation do we need?
7. Which lawful abstraction fits?
Type + operation + laws = lawful structure
Business use case
↓
Identify domain states
↓
Represent states as types
↓
Identify valid transitions
↓
Represent transitions as functions
↓
Ask whether each transition is plain, optional, failing, accumulating, async, etc.
↓
Choose abstraction:
- plain function
- Option
- Validation
- Result
- Async<Result<_,_>>
↓
Use laws to ensure operations preserve meaning
↓
Compose small lawful parts into larger workflows
> We represented domain states as types, business transitions as arrows, and used lawful abstractions like Applicative, Monad, Semigroup, Kleisli composition, and natural transformation-like conversion to compose the workflow safely.
***
# 5. The Bigger Picture
Think of category theory as a **language of composition**.
Our implementation used that language to answer:
| Design question | Category-theoretic idea |
| -------------------------------------------- | -------------------------------------- |
| What domain states exist? | Objects |
| What transitions are valid? | Morphisms |
| Can steps compose directly? | Composition |
| What if a step can fail? | Result / Monad |
| What if validations are independent? | Applicative |
| How do we collect errors? | Semigroup / Monoid |
| How do we compose failing functions? | Kleisli category |
| How do we move from validation to execution? | Natural transformation-like conversion |
| What must remain true? | Laws |
***
```text
We are not inventing category theory.
We are discovering category-theoretic structures inside our domain model.
```
Once you start seeing this, the rest of the concepts become much easier:
* Functor = preserving structure while mapping
* Applicative = combining independent contextual values
* Monad = sequencing dependent contextual computations
* Kleisli category = composing effectful domain transitions
* Natural transformation = moving between contexts consistently
* Isomorphism = lossless representation change
* Monoid = lawful combination
```text
Product/coproduct types define valid states.
Morphisms define valid transitions.
Composition defines valid workflows.
```
### Common Contravariant Structures
Validator<A> = A -> bool
Predicate<A> = A -> bool
Printer<A> = A -> string
Encoder<A> = A -> Json
Comparer<A> = A -> A -> int
Equality<A> = A -> A -> bool
Consumer<A> = A -> unit
Sink<A> = A -> Effect
Consumer<A> = contravariant
Producer<A> = covariant
Transformer<A,B> = profunctor-like
```text
Contravariant = adapt reusable consumers/checks
Applicative = combine independent validation results
Monad = sequence dependent business steps
```
```text
Contravariant Rules
↓
Applicative Validation
↓
Natural transformation to Result
↓
Monad / Kleisli execution workflow
```
A Profunctor represents something that consumes an input and produces an output.
Therefore, we can adapt both sides:
* adapt the input backward,
* adapt the output forward.
```text
dimap : ('a2 -> 'a) -> ('b -> 'b2) -> P<'a, 'b> -> P<'a2, 'b2>
let dimap before after p = before >> p >> after
```
```text
So use lenses when:
* the update is structurally safe,
* the field replacement is meaningful,
* you need composable nested updates,
* you are working with DTOs/configs/view models,
* invariants are already protected by types.
Avoid raw lenses when:
* arbitrary field setting can break invariants,
* domain operation needs validation,
* update has business rules.
```
```text
Independent field checks → Applicative Validation
Dependent domain transitions → Result Monad / Kleisli
External calls → Async<Result<_,_>>
DTO mapping → Functor/Bifunctor/Profunctor
State transitions → Typed arrows
Aggregation → Monoid/Fold
```
Algebraic API = capabilities as functions
Free DSL = capabilities as data
Interpreter = implementation of capabilities
Raw
gistfile2.txt
# **Category Theory with F#: From Composition to Supply Chain Domain Modeling**
***
# Guiding Learning Method
Every chapter will follow this pattern:
```text
1. Start with a concrete F# / domain problem
2. Discover the recurring composition pattern
3. Derive the abstraction
4. Introduce formal category theory definition
5. Study equations and laws
6. Encode the idea in F#
7. Apply it to domain modeling
8. Connect it to supply chain implementation
```
So we will not learn like this:
```text
Definition → Theorem → Example
```
Instead, we will learn like this:
```text
Problem → Need → Pattern → Abstraction → Definition → Laws → F# → Domain Design
```
This is the best fit for your preferred **constructive / derivational learning approach**.
***
# Course Outline
## Part 0 — Orientation
### 1. Why Category Theory for F# Developers?
Purpose:
* Why category theory matters for software design
* Why composition is the central theme
* Why F# is a good host language
* How category theory helps domain modeling
* How the constructive learning approach will work
***
# Part 1 — Composition Foundations
### 2. Functions, Composition, and Identity
We begin from ordinary F# functions.
Concepts:
* Function composition
* Identity
* Associativity
* Pipelines
* Information flow
Formal ideas:
```text
id_A : A → A
g ∘ f : A → C
```
***
### 3. Categories
Concepts:
* Objects
* Morphisms
* Identity morphisms
* Composition
* Category laws
F# intuition:
```text
Types ≈ Objects
Functions ≈ Morphisms
```
***
### 4. Reasoning with Laws
Concepts:
* Equational reasoning
* Lawful abstractions
* Refactoring safely
* Laws as design contracts
Main question:
> What must remain true after transformation?
***
# Part 2 — Data Shape and Structure
### 5. Product Types, Coproduct Types, and Algebraic Data Types
Concepts:
* Records
* Tuples
* Discriminated unions
* AND types
* OR types
* Domain modeling with shape
Formal intuition:
```text
Product : A × B
Coproduct : A + B
```
***
### 6. Initial and Terminal Objects
Concepts:
* Terminal object
* Initial object
* Unit
* Impossible values
* Unique morphisms
Formal ideas:
```text
Terminal object: for every A, exactly one morphism A → 1
Initial object : for every A, exactly one morphism 0 → A
```
***
# Part 3 — Structure-Preserving Mappings
### 7. Functors
Concepts:
* Mapping inside structure
* Preserving shape
* `map`
* Containers and contexts
Laws:
```text
F(id) = id
F(g ∘ f) = F(g) ∘ F(f)
```
F# examples:
* `Option.map`
* `List.map`
* `Result.map`
***
### 8. Bifunctors and Higher-Kinded Patterns in F\#
Concepts:
* Mapping over two type parameters
* Working around lack of native higher-kinded types
* Error/value transformations
F# examples:
* `Result<'error, 'value>`
* Pair-like structures
* Domain outcomes
***
### 9. Natural Transformations
Concepts:
* Transforming one context into another
* Preserving meaning across structures
Formal idea:
```text
η : F ⇒ G
```
Naturality law:
```text
G f ∘ η_A = η_B ∘ F f
```
***
# Part 4 — Combining and Sequencing Computations
### 10. Semigroups and Monoids
Concepts:
* Combining values
* Associativity
* Identity
* Aggregation
* Folding
Laws:
```text
(a <> b) <> c = a <> (b <> c)
empty <> a = a
a <> empty = a
```
Supply chain examples:
* Inventory quantity aggregation
* Error accumulation
* Demand aggregation
***
### 11. Applicative Functors
Concepts:
* Independent computations in context
* Validation
* Error accumulation
* Building values from validated parts
Operations:
```text
pure : A → F A
(<*>) : F (A → B) → F A → F B
```
***
### 12. Monads
Concepts:
* Dependent sequencing
* Context-aware workflows
* `bind`
* `return`
Operations:
```text
return : A → M A
bind : M A → (A → M B) → M B
```
Monad laws:
```text
return a >>= f = f a
m >>= return = m
(m >>= f) >>= g = m >>= (fun x -> f x >>= g)
```
***
### 13. Kleisli Categories
Concepts:
* Composing effectful functions
* Functions of shape:
```text
A → M B
```
Used for:
* Fail-fast pipelines
* Service orchestration
* Domain workflows
* Order processing
***
### 14. Computation Expressions
Concepts:
* F# syntax for contextual computation
* `Bind`
* `Return`
* `ReturnFrom`
* `and!`
* `MergeSources`
This chapter connects category theory to idiomatic F#.
***
# Part 5 — Direction, Consumption, and Transformation
### 15. Contravariant Functors
Concepts:
* Consumers
* Validators
* Comparers
* Printers
* Encoders
Operation:
```text
contramap : (B → A) → F A → F B
```
***
### 16. Profunctors
Concepts:
* Things that consume and produce
* Input/output adaptation
* Bidirectional transformation
Operation:
```text
dimap : (A' → A) → (B → B') → P A B → P A' B'
```
***
### 17. Isomorphisms
Concepts:
* Lossless conversion
* Equivalent representations
* Safe refactoring
Formal condition:
```text
g ∘ f = id_A
f ∘ g = id_B
```
***
# Part 6 — Advanced Abstractions
### 18. F-Algebras, Catamorphisms, and Folding
Concepts:
* Recursive data
* Folding
* Interpretation
* Event folding
Formal intuition:
```text
F A → A
```
Supply chain examples:
* Fold order lines into totals
* Fold shipment events into shipment state
* Fold demand signals into forecast input
***
### 19. Free Structures and DSLs
Concepts:
* Free monoids
* Free applicatives
* Free monads
* Description vs interpretation
* Embedded DSLs in F#
***
### 20. Adjunctions
Concepts:
* Free/forgetful relationships
* Adding structure
* Forgetting structure
* Moving between modeling worlds
Formal idea:
```text
Hom_D(F A, B) ≅ Hom_C(A, G B)
```
***
### 21. Lenses and Optics
Concepts:
* Focusing into immutable data
* Getters
* Setters
* Composable updates
* Nested domain models
***
# Part 7 — Domain Modeling with Category Theory
### 22. Types as Domain Constraints
Concepts:
* Domain primitives
* Smart constructors
* Refined types
* Total functions
* Illegal states unrepresentable
Examples:
* `Sku`
* `WarehouseId`
* `Quantity`
* `LeadTime`
* `Demand`
* `ShipmentId`
***
### 23. Domain Workflows as Composable Arrows
Concepts:
* Workflows as transformations
* State transitions
* Valid business movements
* Composition of steps
Shapes:
```text
A → B
A → Result<Error, B>
A → Async<Result<Error, B>>
```
***
### 24. Error Modeling, Validation, and Partiality
Concepts:
* Partial functions
* Total functions
* `Option`
* `Result`
* Validation
* Error accumulation vs fail-fast
***
### 25. Algebraic API Design
Concepts:
* APIs as algebras
* Capabilities
* Ports and adapters
* Interpreters
* Lawful module boundaries
Examples:
* Inventory service algebra
* Supplier service algebra
* Shipment service algebra
* Forecasting service algebra
***
# Part 8 — Supply Chain Application Chapters
### 26. Supply Chain Domain Model: Core Types and Invariants
We build the foundation of a supply chain model.
Areas:
* Products
* SKUs
* Warehouses
* Suppliers
* Inventory
* Orders
* Shipments
* Routes
* Lead times
***
### 27. Inventory and Order Validation Pipeline
Concepts applied:
* Applicative validation
* Monadic sequencing
* Error semigroups
* Kleisli composition
Flow:
```text
RawOrder
→ Validate customer
→ Validate SKUs
→ Validate quantities
→ Check inventory
→ Reserve stock
→ Confirm order
```
***
### 28. Procurement and Supplier Selection Workflow
Concepts applied:
* Monoids
* Contravariant comparers
* Result workflows
* Domain algebras
* Natural transformations
Concerns:
* Lead time
* MOQ
* Cost
* Reliability
* Capacity
* Region
* Compliance
***
### 29. Shipment Planning and State Transitions
Concepts applied:
* Categories as state machines
* Morphisms as valid transitions
* Coproducts as event types
* Catamorphisms for event folding
* Lenses for immutable updates
Lifecycle:
```text
Planned
→ Booked
→ Picked
→ Dispatched
→ InTransit
→ Delivered
→ Closed
```
***
### 30. Demand Forecasting and Data Transformation Boundaries
Concepts applied:
* Functors
* Natural transformations
* Profunctors
* Isomorphisms
* Algebraic API boundaries
Flow:
```text
RawDemandSignal
→ CleanedDemandSignal
→ AggregatedDemand
→ ForecastInput
→ ForecastResult
→ ReplenishmentRecommendation
```
***
### 31. Building a Mini Supply Chain DSL in F\#
Concepts applied:
* Free structures
* DSL design
* Interpreters
* Algebraic APIs
Possible interpreters:
* Execute
* Log
* Simulate
* Test
* Generate documentation
* Estimate cost/time
***
### 32. End-to-End Supply Chain Case Study
Final integration:
```text
Demand Signal
→ Replenishment Decision
→ Supplier Selection
→ Purchase Order Creation
→ Inbound Shipment
→ Warehouse Receipt
→ Inventory Update
→ Customer Order Fulfillment
```
This chapter brings together:
* Algebraic data types
* Functors
* Applicatives
* Monads
* Kleisli composition
* Monoids
* Natural transformations
* State transitions
* F-algebras
* DSLs
* Domain modeling
***
# Final Learning Architecture
To make the course effective, I suggest we use a **spiral approach**.
That means we will revisit key ideas multiple times at increasing depth.
## Spiral 1 — Intuition
We first understand the concept through ordinary F# code.
Example:
```text
map transforms a value inside a context.
```
## Spiral 2 — Formalization
Then we introduce the category theory definition and laws.
Example:
```text
F(id) = id
F(g ∘ f) = F(g) ∘ F(f)
```
## Spiral 3 — Design Meaning
Then we ask what the concept means for software design.
Example:
```text
Functor preserves structure while transforming information.
```
## Spiral 4 — Domain Modeling
Then we apply the idea to real business modeling.
Example:
```text
Transform validated order data without losing validation context.
```
## Spiral 5 — Supply Chain Implementation
Finally, we use it in realistic supply chain workflows.
Example:
```text
RawOrder → ValidatedOrder → ReservedOrder → ConfirmedOrder
```
***
# How We’ll Handle Each Chapter
For consistency, I’ll structure each chapter like this:
```text
1. Chapter goal
2. Concrete F# problem
3. Naive implementation
4. Pain point
5. Pattern discovery
6. Derived abstraction
7. Formal category theory definition
8. Laws and equations
9. F# implementation
10. Domain modeling interpretation
11. Supply chain example
12. Exercises
13. Summary
```
This gives us both:
* practical intuition, and
* mathematical precision.
***
Raw
gistfile3.txt
module SupplyChain.Supply
open SharedKernel.DomainTypes
open SharedKernel
type RawInventoryBalance =
{
InventoryId: string
ProductId: string
LocationId: string
OnHandQuantity: decimal
ReservedQuantity: decimal
SnapshotDate: System.DateOnly
}
type RawProducedSupply =
{
ProductionOrderId: string
ProductId: string
LocationId: string
Quantity: decimal
AvailableDate: System.DateOnly
}
type RawPurchaseSupply =
{
PurchaseOrderId: string
ProductId: string
LocationId: string
Quantity: decimal
ExpectedReceiptDate: System.DateOnly
}
type SupplyId = private SupplyId of string
type ReservationId = private ReservationId of string
type ProductionOrderId = private ProductionOrderId of string
type PurchaseOrderId = private PurchaseOrderId of string
type SupplyType =
| OnHandInventory
| ProducedSupply
| PurchaseOrderSupply
| FirmProductionOrder
| PlannedProduction
type InventoryBalance =
{
InventoryId: SupplyId
ProductId: ProductId
LocationId: LocationId
OnHand: Quantity
Reserved: Quantity
SnapshotDate: System.DateOnly
}
type ProducedSupply =
{
ProductionOrderId: ProductionOrderId
ProductId: ProductId
LocationId: LocationId
Quantity: Quantity
AvailableDate: System.DateOnly
}
type PurchaseSupply =
{
PurchaseOrderId: PurchaseOrderId
ProductId: ProductId
LocationId: LocationId
Quantity: Quantity
ExpectedReceiptDate: System.DateOnly
}
type AvailableSupply =
{
SupplyId: SupplyId
SupplyType: SupplyType
ProductId: ProductId
LocationId: LocationId
AvailableQuantity: Quantity
AvailableDate: System.DateOnly
}
type SupplyError =
| Supplyailed of ValidationError list
| SupplyNotFound of SupplyId
| InsufficientSupply of ProductId * requested: Quantity * available: Quantity
| SupplyPreparationFailed of string
open Common.Validator
module SupplyId =
let create value =
value
|> String.requireNonEmpty "SupplyId"
|> map SupplyId
let value (SupplyId x) = x
module ProductionOrderId =
let create value =
value
|> String.requireNonEmpty "ProductionOrderId"
|> map ProductionOrderId
let value (ProductionOrderId x) = x
module PurchaseOrderId =
let create value =
value
|> String.requireNonEmpty "PurchaseOrderId"
|> map PurchaseOrderId
let value (PurchaseOrderId x) = x
let makeInventoryBalance inventoryId productId locationId onHand reserved snapshotDate =
{
InventoryId = inventoryId
ProductId = productId
LocationId = locationId
OnHand = onHand
Reserved = reserved
SnapshotDate = snapshotDate
}
let validateInventoryBalance (raw: RawInventoryBalance) =
makeInventoryBalance
<!> SupplyId.create raw.InventoryId
<*> ProductId.create raw.ProductId
<*> LocationId.create raw.LocationId
<*> Quantity.createNonNegative raw.OnHandQuantity
<*> Quantity.createNonNegative raw.ReservedQuantity
<*> return' raw.SnapshotDate
let makeProducedSupply productionOrderId productId locationId quantity availableDate =
{
ProductionOrderId = productionOrderId
ProductId = productId
LocationId = locationId
Quantity = quantity
AvailableDate = availableDate
}
let validateProducedSupply (raw: RawProducedSupply) =
makeProducedSupply
<!> ProductionOrderId.create raw.ProductionOrderId
<*> ProductId.create raw.ProductId
<*> LocationId.create raw.LocationId
<*> Quantity.createPositive raw.Quantity
<*> return' raw.AvailableDate
let makePurchaseSupply purchaseOrderId productId locationId quantity expectedReceiptDate =
{
PurchaseOrderId = purchaseOrderId
ProductId = productId
LocationId = locationId
Quantity = quantity
ExpectedReceiptDate = expectedReceiptDate
}
let validatePurchaseSupply (raw: RawPurchaseSupply) =
makePurchaseSupply
<!> PurchaseOrderId.create raw.PurchaseOrderId
<*> ProductId.create raw.ProductId
<*> LocationId.create raw.LocationId
<*> Quantity.createPositive raw.Quantity
<*> return' raw.ExpectedReceiptDate
let inventoryToAvailableSupply inventory =
let availableResult =
Quantity.subtract inventory.OnHand inventory.Reserved
match availableResult with
| Ok available ->
Valid
{
SupplyId = inventory.InventoryId
SupplyType = OnHandInventory
ProductId = inventory.ProductId
LocationId = inventory.LocationId
AvailableQuantity = available
AvailableDate = inventory.SnapshotDate
}
| Error _ ->
Invalid
[
InvalidNonNegativeQuantity
("AvailableInventory", -1M)
]
let producedSupplyToAvailableSupply produced =
let supplyIdText =
sprintf "PROD-%s" (ProductionOrderId.value produced.ProductionOrderId)
let make supplyId =
{
SupplyId = supplyId
SupplyType = ProducedSupply
ProductId = produced.ProductId
LocationId = produced.LocationId
AvailableQuantity = produced.Quantity
AvailableDate = produced.AvailableDate
}
SupplyId.create supplyIdText
|> map make
let purchaseSupplyToAvailableSupply purchase =
let supplyIdText =
sprintf "PO-%s" (PurchaseOrderId.value purchase.PurchaseOrderId)
let make supplyId =
{
SupplyId = supplyId
SupplyType = PurchaseOrderSupply
ProductId = purchase.ProductId
LocationId = purchase.LocationId
AvailableQuantity = purchase.Quantity
AvailableDate = purchase.ExpectedReceiptDate
}
SupplyId.create supplyIdText
|> map make
let prepareSupply rawInventory rawProduced rawPurchases =
let inventorySupply =
rawInventory
|> traverse validateInventoryBalance
|> function
| Valid balances ->
balances
|> traverse inventoryToAvailableSupply
| Invalid errors ->
Invalid errors
let producedSupply =
rawProduced
|> traverse validateProducedSupply
|> function
| Valid produced ->
produced
|> traverse producedSupplyToAvailableSupply
| Invalid errors ->
Invalid errors
let purchaseSupply =
rawPurchases
|> traverse validatePurchaseSupply
|> function
| Valid purchases ->
purchases
|> traverse purchaseSupplyToAvailableSupply
| Invalid errors ->
Invalid errors
let combineSupply inventory produced purchases =
inventory @ produced @ purchases
combineSupply
<!> inventorySupply
<*> producedSupply
<*> purchaseSupply
module SupplyChain.Capacity
open SharedKernel.DomainTypes
open SharedKernel
open MasterData
open Common.Validator
type CapacityReservationId = private CapacityReservationId of string
type Resource =
{
ResourceId: ResourceId
Description: string
LocationId: LocationId
}
type CapacityBucket =
{
ResourceId: ResourceId
BucketDate: System.DateOnly
LocationId: LocationId
AvailableHours: decimal
ReservedHours: decimal
}
module CapacityBucket =
let remainingHours bucket =
bucket.AvailableHours - bucket.ReservedHours
let canReserve requiredHours bucket =
remainingHours bucket >= requiredHours
type CapacityRequirement =
{
PlannedProductionOrderId: string
ProductId: ProductId
LocationId: LocationId
ResourceId: ResourceId
RequiredDate: System.DateOnly
RequiredHours: decimal
OperationNo: int
}
type CapacityReservation =
{
CapacityReservationId: CapacityReservationId
PlannedProductionOrderId: string
ResourceId: ResourceId
LocationId: LocationId
ReservationDate: System.DateOnly
ReservedHours: decimal
}
type ProductionRequirement =
{
ProductId: ProductId
LocationId: LocationId
Quantity: Quantity
}
type ProductionLimit =
{
ProductId: ProductId
LocationId: LocationId
MinProductionQuantity: Quantity
MaxProductionQuantity: Quantity
}
type ProductionLimitError =
| BelowMinimumProduction of productId: ProductId * locationId: LocationId * requested: Quantity * minimum: Quantity
| AboveMaximumProduction of productId: ProductId * locationId: LocationId * requested: Quantity * maximum: Quantity
| ProductionNotAllowedAtLocation of productId: ProductId * locationId: LocationId
type CapacityPlanningError =
| RoutingMissing of ProductId * LocationId
| ResourceMissing of ResourceId
| CapacityBucketMissing of ResourceId * System.DateOnly
| CapacityNotAvailable of resourceId: ResourceId * date: System.DateOnly * required: decimal * available: decimal
| ProductionLimitViolation of ProductionLimitError
| TransferLaneMissing of ProductId * fromLocation: LocationId * toLocation: LocationId
| TransferNotAllowed of ProductId * fromLocation: LocationId * toLocation: LocationId
| CapacityPlanningFailed of string
type CapacityError =
| ResourceNotFound of ResourceId
| PlanningError of CapacityPlanningError
type CapacityPlanningState =
{
Buckets: CapacityBucket list
Reservations: CapacityReservation list
Shortages: CapacityPlanningError list
Messages: string list
}
let initialCapacityPlanningState buckets =
{
Buckets = buckets
Reservations = []
Shortages = []
Messages = []
}
module CapacityReservationId =
open Common.Validator
let create value =
value
|> String.requireNonEmpty "CapacityReservationId"
|> map CapacityReservationId
let value (CapacityReservationId x) = x
let checkProductionLimit limit (plannedOrder: ProductionRequirement) =
if plannedOrder.ProductId <> limit.ProductId
|| plannedOrder.LocationId <> limit.LocationId then
Error (ProductionNotAllowedAtLocation (plannedOrder.ProductId, plannedOrder.LocationId))
elif Quantity.value plannedOrder.Quantity < Quantity.value limit.MinProductionQuantity then
Error
(BelowMinimumProduction
(plannedOrder.ProductId,
plannedOrder.LocationId,
plannedOrder.Quantity,
limit.MinProductionQuantity))
elif Quantity.value plannedOrder.Quantity > Quantity.value limit.MaxProductionQuantity then
Error
(AboveMaximumProduction
(plannedOrder.ProductId,
plannedOrder.LocationId,
plannedOrder.Quantity,
limit.MaxProductionQuantity))
else
Ok plannedOrder
let calculateRequiredHours quantity operation =
operation.SetupTimeHours + (Quantity.value quantity * operation.RunTimeHoursPerUnit)
let makeCapacityReservationId (requirement: CapacityRequirement) =
sprintf
"CAPRES-%s-%s-%s"
requirement.PlannedProductionOrderId
(ResourceId.value requirement.ResourceId)
(requirement.RequiredDate.ToString("yyyyMMdd"))
|> CapacityReservationId.create
let reserveCapacityRequirement state (requirement: CapacityRequirement) =
let matchingBucket =
state.Buckets
|> List.tryFind (fun bucket ->
bucket.ResourceId = requirement.ResourceId
&& bucket.LocationId = requirement.LocationId
&& bucket.BucketDate = requirement.RequiredDate)
match matchingBucket with
| None ->
{
state with
Shortages =
CapacityBucketMissing (requirement.ResourceId, requirement.RequiredDate)
:: state.Shortages
}
| Some bucket ->
let available =
CapacityBucket.remainingHours bucket
if available < requirement.RequiredHours then
{
state with
Shortages =
CapacityNotAvailable
(requirement.ResourceId,
requirement.RequiredDate,
requirement.RequiredHours,
available)
:: state.Shortages
}
else
match makeCapacityReservationId requirement with
| Invalid errors ->
{
state with
Shortages =
CapacityPlanningFailed (sprintf "%A" errors)
:: state.Shortages
}
| Valid reservationId ->
let reservation =
{
CapacityReservationId = reservationId
PlannedProductionOrderId = requirement.PlannedProductionOrderId
ResourceId = requirement.ResourceId
LocationId = requirement.LocationId
ReservationDate = requirement.RequiredDate
ReservedHours = requirement.RequiredHours
}
let updatedBucket =
{
bucket with
ReservedHours = bucket.ReservedHours + requirement.RequiredHours
}
{
state with
Buckets =
state.Buckets
|> List.map (fun b ->
if b.ResourceId = bucket.ResourceId
&& b.LocationId = bucket.LocationId
&& b.BucketDate = bucket.BucketDate then
updatedBucket
else
b)
Reservations = reservation :: state.Reservations
Messages =
sprintf
"Reserved %M hours on resource %s for production order %s."
requirement.RequiredHours
(ResourceId.value requirement.ResourceId)
requirement.PlannedProductionOrderId
:: state.Messages
}
let reserveCapacityRequirements buckets requirements =
let finalState =
requirements
|> List.fold reserveCapacityRequirement (initialCapacityPlanningState buckets)
{
finalState with
Reservations = List.rev finalState.Reservations
Shortages = List.rev finalState.Shortages
Messages = List.rev finalState.Messages
}
let findRouting (routings: Routing list) (req: ProductionRequirement) =
routings
|> List.tryFind (fun routing ->
routing.ProductId = req.ProductId
&& routing.LocationId = req.LocationId)
let findProductionLimit limits (req: ProductionRequirement) =
limits
|> List.tryFind (fun limit ->
limit.ProductId = req.ProductId
&& limit.LocationId = req.LocationId)
let validateProductionLimit limits (req: ProductionRequirement) =
match findProductionLimit limits req with
| None ->
Error
(ProductionLimitViolation
(ProductionNotAllowedAtLocation
(req.ProductId, req.LocationId)))
| Some limit ->
checkProductionLimit limit req
|> Result.mapError ProductionLimitViolation
module SupplyChain.Demand
open SharedKernel
open SharedKernel.DomainTypes
open Common.Validator
type RawOrderLine =
{
OrderLineId: string
ProductId: string
Quantity: decimal
RequestedDate: System.DateOnly
}
type RawCustomerOrder =
{
OrderId: string
CustomerId: string
ShipToLocationId: string
Lines: RawOrderLine list
}
type RawForecastDemand =
{
ForecastId: string
ProductId: string
LocationId: string
Quantity: decimal
ForecastDate: System.DateOnly
}
type DemandId = private DemandId of string
type OrderId = private OrderId of string
type OrderLineId = private OrderLineId of string
type ForecastId = private ForecastId of string
type DemandSource =
| SalesOrder
| Forecast
type DemandRequirement =
{
DemandId: DemandId
Source: DemandSource
ProductId: ProductId
LocationId: LocationId
RequiredQuantity: Quantity
DueDate: System.DateOnly
Priority: int
}
type OrderLine =
{
OrderLineId: OrderLineId
ProductId: ProductId
Quantity: Quantity
RequestedDate: System.DateOnly
}
type CustomerOrder =
{
OrderId: OrderId
CustomerId: CustomerId
Lines: OrderLine list
ShipToLocationId: LocationId
}
type ForecastDemand =
{
ForecastId: ForecastId
ProductId: ProductId
LocationId: LocationId
Quantity: Quantity
ForecastDate: System.DateOnly
}
type DemandError =
| DemandValidationFailed of ValidationError list
| DemandNotFound of DemandId
| DemandPreparationFailed of string
module DemandId =
let create value =
value
|> String.requireNonEmpty "DemandId"
|> map DemandId
let value (DemandId x) = x
module OrderId =
let create value =
value
|> String.requireNonEmpty "OrderId"
|> map OrderId
let value (OrderId x) = x
module OrderLineId =
let create value =
value
|> String.requireNonEmpty "OrderLineId"
|> map OrderLineId
let value (OrderLineId x) = x
module ForecastId =
let create value =
value
|> String.requireNonEmpty "ForecastId"
|> map ForecastId
let value (ForecastId x) = x
let makeOrderLine orderLineId productId quantity requestedDate =
{
OrderLineId = orderLineId
ProductId = productId
Quantity = quantity
RequestedDate = requestedDate
}
let validateOrderLine (raw: RawOrderLine) =
makeOrderLine
<!> OrderLineId.create raw.OrderLineId
<*> ProductId.create raw.ProductId
<*> Quantity.createPositive raw.Quantity
<*> return' raw.RequestedDate
let makeCustomerOrder orderId customerId shipToLocationId lines =
{
OrderId = orderId
CustomerId = customerId
ShipToLocationId = shipToLocationId
Lines = lines
}:CustomerOrder
open SharedKernel.DomainTypes
let validateCustomerOrder (raw: RawCustomerOrder) =
makeCustomerOrder
<!> OrderId.create raw.OrderId
<*> CustomerId.create raw.CustomerId
<*> LocationId.create raw.ShipToLocationId
<*> traverse validateOrderLine raw.Lines
let makeForecastDemand forecastId productId locationId quantity forecastDate =
{
ForecastId = forecastId
ProductId = productId
LocationId = locationId
Quantity = quantity
ForecastDate = forecastDate
}
let validateForecastDemand (raw: RawForecastDemand) =
makeForecastDemand
<!> ForecastId.create raw.ForecastId
<*> ProductId.create raw.ProductId
<*> LocationId.create raw.LocationId
<*> Quantity.createPositive raw.Quantity
<*> return' raw.ForecastDate
let demandIdFromOrderLine (orderId: OrderId) (lineId: OrderLineId) =
let id =
sprintf "SO-%s-%s" (OrderId.value orderId) (OrderLineId.value lineId)
// safe because generated internally
DemandId.create id
let orderLineToDemandRequirement order (line: OrderLine) =
let make demandId =
{
DemandId = demandId
Source = SalesOrder
ProductId = line.ProductId
LocationId = order.ShipToLocationId
RequiredQuantity = line.Quantity
DueDate = line.RequestedDate
Priority = 1
}
demandIdFromOrderLine order.OrderId line.OrderLineId
|> map make
let customerOrderToDemandRequirements order =
order.Lines
|> traverse (orderLineToDemandRequirement order)
let demandIdFromForecast (forecastId: ForecastId) =
let id =
sprintf "FC-%s" (ForecastId.value forecastId)
DemandId.create id
let forecastToDemandRequirement forecast =
let make demandId =
{
DemandId = demandId
Source = Forecast
ProductId = forecast.ProductId
LocationId = forecast.LocationId
RequiredQuantity = forecast.Quantity
DueDate = forecast.ForecastDate
Priority = 5
}
demandIdFromForecast forecast.ForecastId
|> map make
let prepareDemand rawOrders rawForecasts =
let orderRequirements =
rawOrders
|> traverse validateCustomerOrder
|> map
(fun orders ->
orders
|> List.map customerOrderToDemandRequirements)
|> function
| Valid validations ->
sequence validations
|> map List.concat
| Invalid errors ->
Invalid errors
let forecastRequirements =
rawForecasts
|> traverse validateForecastDemand
|> function
| Valid forecasts ->
forecasts
|> traverse forecastToDemandRequirement
| Invalid errors ->
Invalid errors
let combineDemand orderReqs forecastReqs =
orderReqs @ forecastReqs
combineDemand
<!> orderRequirements
<*> forecastRequirements
namespace SupplyChain.Domain
open System
module ResultEx =
let mapError f = Result.mapError f
let sequence (results: Result<'a, 'e> list) : Result<'a list, 'e list> =
let folder next state =
match next, state with
| Ok value, Ok values -> Ok (value :: values)
| Error err, Ok _ -> Error [ err ]
| Ok _, Error errors -> Error errors
| Error err, Error errors -> Error (err :: errors)
List.foldBack folder results (Ok [])
type DomainError =
| ValidationError of string
| DataError of string
| MlError of string
| OptimizationError of string
type SkuId = private SkuId of string
module SkuId =
let create (raw: string) =
if String.IsNullOrWhiteSpace raw then
Error (ValidationError "SKU id cannot be blank")
else
raw.Trim().ToUpperInvariant() |> SkuId |> Ok
let value (SkuId value) = value
type LocationId = private LocationId of string
module LocationId =
let create (raw: string) =
if String.IsNullOrWhiteSpace raw then
Error (ValidationError "Location id cannot be blank")
else
raw.Trim().ToUpperInvariant() |> LocationId |> Ok
let value (LocationId value) = value
type DemandObservation = {
Sku: SkuId
Location: LocationId
Date: DateTime
Quantity: int
}
type DemandSeries = {
Sku: SkuId
Location: LocationId
Values: (DateTime * float) list
}
type InventoryPolicy = {
LeadTimeDays: int
ReviewPeriodDays: int
ServiceLevelZ: float
}
type InventoryPosition = {
Sku: SkuId
Location: LocationId
OnHand: int
OnOrder: int
UnitCost: decimal
HoldingCostPerUnit: decimal
StockoutPenaltyPerUnit: decimal
Policy: InventoryPolicy
}
type SupplierCapacity = {
Sku: SkuId
TotalUnitsAvailable: int
}
type ForecastSource =
| MlNet
| OnnxModel of string
type ForecastRequest = {
Series: DemandSeries
Inventory: InventoryPosition
HorizonDays: int
}
type Forecast = {
Sku: SkuId
Location: LocationId
HorizonDays: int
DailyDemand: int list
MeanDailyDemand: float
TotalDemand: int
DemandStdDev: float
SafetyStock: int
ReorderPoint: int
Source: ForecastSource
}
type OptimizationProblem = {
Forecasts: Forecast list
Inventories: InventoryPosition list
Capacities: SupplierCapacity list
}
type ReplenishmentDecision = {
Sku: SkuId
Location: LocationId
RecommendedOrderQty: int
ForecastDemand: int
SafetyStock: int
TargetInventory: int
ProjectedEndingInventory: int
ExpectedShortage: int
CostContribution: decimal
}
type ReplenishmentPlan = {
Decisions: ReplenishmentDecision list
TotalOrderQty: int
ObjectiveValue: decimal
Notes: string list
}
type ScenarioReport = {
RunDate: DateTime
Forecasts: Forecast list
Plan: ReplenishmentPlan
Notes: string list
}
module Keys =
let demandKey (sku: SkuId) (location: LocationId) =
SkuId.value sku, LocationId.value location
module DomainRules =
let targetInventory (forecast: Forecast) = forecast.TotalDemand + forecast.SafetyStock
let projectedInventory (inventory: InventoryPosition) orderQty (forecast: Forecast) =
inventory.OnHand + inventory.OnOrder + orderQty - forecast.TotalDemand
let shortageFromProjected projectedInventory =
if projectedInventory < 0 then abs projectedInventory else 0
let endingInventoryFromProjected projectedInventory =
if projectedInventory > 0 then projectedInventory else 0
module SupplyChain.MasterData
open Common.Validator
open SharedKernel.DomainTypes
open SharedKernel
type ProductType =
| FinishedGood
| SemiFinishedGood
| RawMaterial
| PackagingMaterial
type Product =
{
ProductId: ProductId
Description: string
BaseUom: UomCode
ProductType: ProductType
}
type BomLine =
{
ParentProduct: ProductId
ComponentProduct: ProductId
QuantityPer: Quantity
ComponentUom: UomCode
}
type Bom =
{
ParentProduct: ProductId
Lines: BomLine list
}
type OperationNo = private OperationNo of int
type RoutingOperation =
{
OperationNo: OperationNo
ResourceId: ResourceId
RunTimeHoursPerUnit: decimal
SetupTimeHours: decimal
QueueTimeDays: int
MoveTimeDays: int
}
type Routing =
{
ProductId: ProductId
LocationId: LocationId
Operations: RoutingOperation list
}
type TransferLane =
{
FromLocation: LocationId
ToLocation: LocationId
ProductId: ProductId
TransferLeadTimeDays: int
TransferCostPerUnit: decimal
IsAllowed: bool
}
module OperationNo =
let create value =
if value > 0 then
Valid (OperationNo value)
else
Invalid [ InvalidPositiveQuantity ("OperationNo", decimal value) ]
let value (OperationNo x) = x
type MasterDataError =
| ProductNotFound of ProductId
| BomNotFound of ProductId
| RoutingNotFound of ProductId
| InvalidBom of string
| InvalidRouting of string
module SupplyChain.Planning
open Common.Validator
open SharedKernel
open SharedKernel.DomainTypes
open Demand
open Supply
open Capacity
module Materials =
open MasterData
type RequirementSource =
| FromDemand of DemandId
| FromParentRequirement of parentProduct: ProductId
type RequirementLevel =
| Level of int
type MaterialRequirement =
{
Source: RequirementSource
Level: RequirementLevel
ParentProduct: ProductId option
ProductId: ProductId
LocationId: LocationId
RequiredQuantity: Quantity
RequiredDate: System.DateOnly
}
type MaterialRequirementKey =
{
ProductId: ProductId
LocationId: LocationId
RequiredDate: System.DateOnly
}
type BomExplosionResult =
{
DetailedRequirements: MaterialRequirement list
AggregatedRequirements: MaterialRequirement list
}
type BomExplosionError =
| BomCycleDetected of ProductId
| InvalidBomQuantity of parent: ProductId * comp: ProductId
| MasterDataError of MasterData.MasterDataError
| BomExplosionFailed of string
let explodeDemandOneLevel demand bom =
bom.Lines
|> List.map (fun line ->
{
Source = FromDemand demand.DemandId
Level = Level 1
ParentProduct = Some demand.ProductId
ProductId = line.ComponentProduct
LocationId = demand.LocationId
RequiredQuantity = Quantity.multiply demand.RequiredQuantity line.QuantityPer
RequiredDate = demand.DueDate
})
type BomLookup = ProductId -> Async<Result<Bom option, MasterDataError>>
let explodeDemandOneLevelWithLookup (getBom:BomLookup) (demand: DemandRequirement) =
async {
let! bomResult = getBom demand.ProductId
match bomResult with
| Error err -> return Error (MasterDataError err)
| Ok None -> return Ok []
| Ok (Some bom) -> return Ok (explodeDemandOneLevel demand bom)
}
let bindAsyncResult f asyncResult =
async {
let! result = asyncResult
match result with
| Ok value -> return! f value
| Error error -> return Error error
}
let traverseAsyncResult f values =
let folder value acc =
async {
let! accResult = acc
match accResult with
| Error e ->
return Error e
| Ok results ->
let! valueResult = f value
match valueResult with
| Ok x ->
return Ok (x :: results)
| Error e ->
return Error e
}
List.foldBack folder values (async { return Ok [] })
let explodeDemandsOneLevel (getBom:BomLookup) demands =
async {
let! explodedResult =
traverseAsyncResult (explodeDemandOneLevelWithLookup getBom) demands
match explodedResult with
| Error e -> return Error e
| Ok nestedRequirements ->
return Ok (List.concat nestedRequirements)
}
let rec explodeProductRecursive
(getBom: ProductId -> Async<Result<Bom option, MasterDataError>>)
(visited: ProductId list)
(source: RequirementSource)
(locationId: LocationId)
(requiredDate: System.DateOnly)
(level: int)
(parentProduct: ProductId option)
(productId: ProductId)
(requiredQuantity: Quantity)
: Async<Result<MaterialRequirement list, BomExplosionError>> =
async {
if visited |> List.contains productId then
return Error (BomCycleDetected productId)
else
let! bomResult =
getBom productId
match bomResult with
| Error err ->
return Error (MasterDataError err)
| Ok None ->
return Ok []
| Ok (Some bom) ->
let explodeLine line =
async {
let componentQuantity =
Quantity.multiply requiredQuantity line.QuantityPer
let requirement =
{
Source = source
Level = Level level
ParentProduct = Some productId
ProductId = line.ComponentProduct
LocationId = locationId
RequiredQuantity = componentQuantity
RequiredDate = requiredDate
}
let! childResult =
explodeProductRecursive
getBom
(productId :: visited)
source
locationId
requiredDate
(level + 1)
(Some productId)
line.ComponentProduct
componentQuantity
match childResult with
| Error e ->
return Error e
| Ok childRequirements ->
return Ok (requirement :: childRequirements)
}
let! results =
bom.Lines
|> traverseAsyncResult explodeLine
match results with
| Error e ->
return Error e
| Ok nested ->
return Ok (List.concat nested)
}
let explodeDemandRecursive getBom (demand: DemandRequirement) =
explodeProductRecursive
getBom
[]
(FromDemand demand.DemandId)
demand.LocationId
demand.DueDate
1
None
demand.ProductId
demand.RequiredQuantity
let explodeAllDemandsRecursive getBom demands =
async {
let! result =
demands
|> traverseAsyncResult (explodeDemandRecursive getBom)
match result with
| Error e ->
return Error e
| Ok nested ->
return Ok (List.concat nested)
}
let aggregateMaterialRequirements (requirements: MaterialRequirement list) =
requirements
|> List.groupBy (fun r ->
{
ProductId = r.ProductId
LocationId = r.LocationId
RequiredDate = r.RequiredDate
})
|> List.map (fun (key, reqs) ->
let totalQuantity =
reqs
|> List.map (fun r -> r.RequiredQuantity)
|> List.fold Quantity.add Quantity.zero
{
Source = FromParentRequirement key.ProductId
Level = Level 0
ParentProduct = None
ProductId = key.ProductId
LocationId = key.LocationId
RequiredQuantity = totalQuantity
RequiredDate = key.RequiredDate
})
let explodeAndAggregate getBom demands=
async {
let! explosionResult =
explodeAllDemandsRecursive getBom demands
match explosionResult with
| Error e ->
return Error e
| Ok detailed ->
let aggregated =
aggregateMaterialRequirements detailed
return
Ok
{
DetailedRequirements = detailed
AggregatedRequirements = aggregated
}
}
open Materials
open SharedKernel.Quantity
type PeggingId = private PeggingId of string
type PlanId = private PlanId of string
type NetRequirementId = private NetRequirementId of string
type PlannedProductionOrderId = private PlannedProductionOrderId of string
type PlanningInput =
{
PlanningDate: System.DateOnly
HorizonStart: System.DateOnly
HorizonEnd: System.DateOnly
Demands: Demand.DemandRequirement list
Supplies: Supply.AvailableSupply list
Products: MasterData.Product list
Boms: MasterData.Bom list
Routings: MasterData.Routing list
Resources: Capacity.Resource list
CapacityBuckets: Capacity.CapacityBucket list
ProductionLimits: Capacity.ProductionLimit list
TransferLanes: MasterData.TransferLane list
}
type PlanningInputError =
| DemandInputInvalid of SharedKernel.ValidationError list
| SupplyInputInvalid of SharedKernel.ValidationError list
type Pegging =
{
PeggingId: PeggingId
DemandId: DemandId
SupplyId: SupplyId
ProductId: ProductId
Quantity: Quantity
PeggedDate: System.DateOnly
}
type NetRequirement =
{
NetRequirementId: NetRequirementId
DemandId: DemandId
ProductId: ProductId
LocationId: LocationId
RequiredQuantity: Quantity
ShortageQuantity: Quantity
DueDate: System.DateOnly
}
type PlannedProductionOrder =
{
PlannedProductionOrderId: PlannedProductionOrderId
ProductId: ProductId
LocationId: LocationId
Quantity: Quantity
DueDate: System.DateOnly
SourceDemandId: DemandId
}
type NettingResult =
{
Peggings: Pegging list
NetRequirements: NetRequirement list
PlannedProductionOrders: PlannedProductionOrder list
RemainingSupply: AvailableSupply list
Messages: string list
}
type CapacityReservationProposal =
{
ProductId: ProductId
ResourceId: ResourceId
RequiredHours: decimal
RequiredDate: System.DateOnly
}
type InterPlantTransferProposal =
{
ProductId: ProductId
FromLocation: LocationId
ToLocation: LocationId
Quantity: Quantity
ShipDate: System.DateOnly
ArrivalDate: System.DateOnly
}
type CapacityPlanningResult =
{
Requirements: CapacityRequirement list
Reservations: CapacityReservation list
RemainingBuckets: CapacityBucket list
Shortages: CapacityPlanningError list
Messages: string list
}
type PlanningDecision =
| UseExistingSupply of Pegging
| CreatePlannedProduction of PlannedProductionOrder
| ReserveCapacity of CapacityReservationProposal
type SupplyChainPlan =
{
PlanId: PlanId
Peggings: Pegging list
NetRequirements: NetRequirement list
PlannedProductionOrders: PlannedProductionOrder list
RemainingSupply: AvailableSupply list
CapacityRequirements: CapacityRequirement list
CapacityReservations: CapacityReservation list
CapacityShortages: CapacityPlanningError list
TransferProposals: InterPlantTransferProposal list
Messages: string list
}
type PlanningError =
| DemandUnavailable
| SupplyUnavailable
| MasterDataMissing of string
| CapacityUnavailable of string
| PlanningFailed of string
type PlanningStageResult =
{
Input: PlanningInput
NettingResult: NettingResult option
MaterialRequirements: MaterialRequirement list
CapacityPlanningResult: CapacityPlanningResult option
FinalPlan: SupplyChainPlan option
Messages: string list
}
module PeggingId =
let create value =
value
|> String.requireNonEmpty "PeggingId"
|> map PeggingId
let value (PeggingId x) = x
module NetRequirementId =
let create value =
value
|> SharedKernel.String.requireNonEmpty "NetRequirementId"
|> map NetRequirementId
let value (NetRequirementId x) = x
module PlannedProductionOrderId =
let create demandId productId =
sprintf
"PPO-%s-%s"
(DemandId.value demandId)
(ProductId.value productId)
|> PlannedProductionOrderId
let value (PlannedProductionOrderId x) = x
module PlanId =
let create value =
value
|> String.requireNonEmpty "PlanId"
|> map PlanId
let value (PlanId x) = x
let makePeggingId demandId supplyId =
sprintf
"PEG-%s-%s"
(DemandId.value demandId)
(SupplyId.value supplyId)
|> PeggingId.create
let makeNetRequirementId demandId =
sprintf
"NET-%s"
(DemandId.value demandId)
|> NetRequirementId.create
module Ports =
open Demand
open Supply
open MasterData
open Capacity
type DemandPort =
{
GetOpenDemand :
unit -> Async<Result<DemandRequirement list, DemandError>>
}
type SupplyPort =
{
GetAvailableSupply :
unit -> Async<Result<AvailableSupply list, SupplyError>>
}
type MasterDataPort =
{
GetBom :
ProductId -> Async<Result<Bom, MasterDataError>>
GetRouting :
ProductId -> Async<Result<Routing, MasterDataError>>
}
type CapacityPort =
{
CheckCapacity :
CapacityRequirement -> Async<Result<CapacityBucket, CapacityError>>
ReserveCapacity :
CapacityRequirement -> Async<Result<CapacityReservation, CapacityError>>
}
module Heuristics =
let canCover (demand: DemandRequirement) (supply: AvailableSupply) =
demand.ProductId = supply.ProductId
&& demand.LocationId = supply.LocationId
&& supply.AvailableDate <= demand.DueDate
&& Quantity.value supply.AvailableQuantity >= Quantity.value demand.RequiredQuantity
let chooseSupply demand supplies =
supplies
|> List.filter (canCover demand)
|> List.sortBy (fun s -> s.AvailableDate)
|> List.tryHead
let createPlannedProduction (demand: DemandRequirement) =
{
PlannedProductionOrderId = PlannedProductionOrderId.create demand.DemandId demand.ProductId
ProductId = demand.ProductId
LocationId = demand.LocationId
Quantity = demand.RequiredQuantity
DueDate = demand.DueDate
SourceDemandId = demand.DemandId
}
let planDemand demand supplies =
match chooseSupply demand supplies with
| Some supply ->
// For now, PeggingId construction simplified
let pegging =
{
PeggingId = Unchecked.defaultof<_>
DemandId = demand.DemandId
SupplyId = supply.SupplyId
ProductId = demand.ProductId
Quantity = demand.RequiredQuantity
PeggedDate = demand.DueDate
}
UseExistingSupply pegging
| None ->
demand
|> createPlannedProduction
|> CreatePlannedProduction
module PlanBuilder =
open Heuristics
open Demand
open Supply
let buildPlan demands supplies =
let decisions =
demands
|> List.map (fun demand -> planDemand demand supplies)
let peggings =
decisions
|> List.choose (function
| UseExistingSupply pegging -> Some pegging
| _ -> None)
let plannedProductionOrders =
decisions
|> List.choose (function
| CreatePlannedProduction order -> Some order
| _ -> None)
{
PlanId = Unchecked.defaultof<_>
Peggings = peggings
PlannedProductionOrders = plannedProductionOrders
NetRequirements = []
RemainingSupply = []
CapacityRequirements = []
CapacityReservations = []
CapacityShortages = []
TransferProposals = []
Messages =
[
sprintf "Processed %d demand requirements." demands.Length
sprintf "Created %d peggings." peggings.Length
sprintf "Created %d planned production orders." plannedProductionOrders.Length
]
}
module Netting =
open Supply
type ConsumableSupply =
{
Supply: AvailableSupply
RemainingQuantity: Quantity
}
type DemandSupplyMatch =
{
Demand: DemandRequirement
MatchingSupply: AvailableSupply option
}
type DemandNettingState =
{
RemainingDemand: Quantity
Supplies: ConsumableSupply list
Peggings: Pegging list
}
let toConsumableSupply supply =
{
Supply = supply
RemainingQuantity = supply.AvailableQuantity
}
let canSupplyCoverDemand (demand: Demand.DemandRequirement) consumableSupply =
demand.ProductId = consumableSupply.Supply.ProductId
&& demand.LocationId = consumableSupply.Supply.LocationId
&& consumableSupply.Supply.AvailableDate <= demand.DueDate
&& greaterThanZero consumableSupply.RemainingQuantity
let candidateSupplies demand supplies =
supplies
|> List.filter (canSupplyCoverDemand demand)
|> List.sortBy (fun s -> s.Supply.AvailableDate)
let canCover (demand: DemandRequirement) supply =
demand.ProductId = supply.ProductId
&& demand.LocationId = supply.LocationId
&& supply.AvailableDate <= demand.DueDate
&& Quantity.value supply.AvailableQuantity >= Quantity.value demand.RequiredQuantity
let findMatchingSupply supplies demand =
supplies
|> List.filter (canCover demand)
|> List.sortBy (fun s -> s.AvailableDate)
|> List.tryHead
let matchDemandToSupply demands supplies =
demands
|> List.map (fun demand ->
{
Demand = demand
MatchingSupply = findMatchingSupply supplies demand
})
let consumeSupplyForDemand demand state consumableSupply =
if isZero state.RemainingDemand then
state
elif not (canSupplyCoverDemand demand consumableSupply) then
state
else
let peggedQty =
minQuantity
state.RemainingDemand
consumableSupply.RemainingQuantity
let newRemainingDemand =
Quantity.value state.RemainingDemand - Quantity.value peggedQty
|> Quantity.createNonNegative
let newRemainingSupply =
Quantity.value consumableSupply.RemainingQuantity - Quantity.value peggedQty
|> Quantity.createNonNegative
match newRemainingDemand, newRemainingSupply, makePeggingId demand.DemandId consumableSupply.Supply.SupplyId with
| Valid remDemand, Valid remSupply, Valid peggingId ->
let pegging =
{
PeggingId = peggingId
DemandId = demand.DemandId
SupplyId = consumableSupply.Supply.SupplyId
ProductId = demand.ProductId
Quantity = peggedQty
PeggedDate = demand.DueDate
}
let updatedSupply =
{
consumableSupply with RemainingQuantity = remSupply
}
{
RemainingDemand = remDemand
Supplies =
state.Supplies
|> List.map (fun s ->
if s.Supply.SupplyId = consumableSupply.Supply.SupplyId then
updatedSupply
else
s)
Peggings = pegging :: state.Peggings
}
| _ ->
state
type SingleDemandNettingResult =
{
Peggings: Pegging list
NetRequirement: NetRequirement option
PlannedProductionOrder: PlannedProductionOrder option
Supplies: ConsumableSupply list
}
let netSingleDemand supplies (demand: Demand.DemandRequirement):SingleDemandNettingResult =
let initialState =
{
RemainingDemand = demand.RequiredQuantity
Supplies = supplies
Peggings = []
}
let candidates =
candidateSupplies demand supplies
let finalState =
candidates
|> List.fold (consumeSupplyForDemand demand) initialState
let peggings =
finalState.Peggings |> List.rev
if isZero finalState.RemainingDemand then
{
Peggings = peggings
NetRequirement = None
PlannedProductionOrder = None
Supplies = finalState.Supplies
}
else
let netReqResult =
makeNetRequirementId demand.DemandId
let ppoIdResult =
PlannedProductionOrderId.create demand.DemandId demand.ProductId
match netReqResult, ppoIdResult with
| Valid netReqId, ppoId ->
let netRequirement =
{
NetRequirementId = netReqId
DemandId = demand.DemandId
ProductId = demand.ProductId
LocationId = demand.LocationId
RequiredQuantity = demand.RequiredQuantity
ShortageQuantity = finalState.RemainingDemand
DueDate = demand.DueDate
}
let plannedProduction =
{
PlannedProductionOrderId = ppoId
ProductId = demand.ProductId
LocationId = demand.LocationId
Quantity = finalState.RemainingDemand
DueDate = demand.DueDate
SourceDemandId = demand.DemandId
}
{
Peggings = peggings
NetRequirement = Some netRequirement
PlannedProductionOrder = Some plannedProduction
Supplies = finalState.Supplies
}
| _ ->
{
Peggings = peggings
NetRequirement = None
PlannedProductionOrder = None
Supplies = finalState.Supplies
}
type NettingState =
{
Supplies: ConsumableSupply list
Peggings: Pegging list
NetRequirements: NetRequirement list
PlannedProductionOrders: PlannedProductionOrder list
Messages: string list
}
let initialNettingState supplies =
{
Supplies = supplies |> List.map toConsumableSupply
Peggings = []
NetRequirements = []
PlannedProductionOrders = []
Messages = []
}
let netDemand state demand =
let result =
netSingleDemand state.Supplies demand
let messages =
match result.NetRequirement with
| None ->
sprintf
"Demand %s fully covered."
(DemandId.value demand.DemandId)
| Some net ->
sprintf
"Demand %s has shortage %M."
(DemandId.value demand.DemandId)
(Quantity.value net.ShortageQuantity)
{
Supplies = result.Supplies
Peggings = state.Peggings @ result.Peggings
NetRequirements =
match result.NetRequirement with
| Some x -> state.NetRequirements @ [ x ]
| None -> state.NetRequirements
PlannedProductionOrders =
match result.PlannedProductionOrder with
| Some x -> state.PlannedProductionOrders @ [ x ]
| None -> state.PlannedProductionOrders
Messages = state.Messages @ [ messages ]
}
let netDemandAgainstSupply demands supplies =
let orderedDemands =
demands
|> List.sortBy (fun d -> d.Priority, d.DueDate)
let finalState =
orderedDemands
|> List.fold netDemand (initialNettingState supplies)
{
Peggings = finalState.Peggings
NetRequirements = finalState.NetRequirements
PlannedProductionOrders = finalState.PlannedProductionOrders
RemainingSupply =
finalState.Supplies
|> List.map (fun s ->
{
s.Supply with
AvailableQuantity = s.RemainingQuantity
})
Messages = finalState.Messages
}
let runNetting planningInput =
netDemandAgainstSupply
planningInput.Demands
planningInput.Supplies
let buildSupplyChainPlan planId (nettingResult: NettingResult) =
{
PlanId = planId
Peggings = nettingResult.Peggings
NetRequirements = nettingResult.NetRequirements
PlannedProductionOrders = nettingResult.PlannedProductionOrders
RemainingSupply = nettingResult.RemainingSupply
CapacityRequirements = []
CapacityReservations = []
CapacityShortages = []
TransferProposals = []
Messages = nettingResult.Messages
}
open MasterData
let plannedOrderToCapacityRequirements (plannedOrder: PlannedProductionOrder) routing =
routing.Operations
|> List.map (fun operation ->
{
PlannedProductionOrderId = PlannedProductionOrderId.value plannedOrder.PlannedProductionOrderId
ProductId = plannedOrder.ProductId
LocationId = plannedOrder.LocationId
ResourceId = operation.ResourceId
RequiredDate = plannedOrder.DueDate.AddDays(-(operation.QueueTimeDays + operation.MoveTimeDays))
RequiredHours = calculateRequiredHours plannedOrder.Quantity operation
OperationNo = OperationNo.value operation.OperationNo
}:CapacityRequirement)
let createRequirementsForOrder routings req =
match findRouting routings req with
| Some routing -> Ok routing
| None -> Error (RoutingMissing (req.ProductId, req.LocationId))
let planCapacityForOrder limits routings (plannedOrder: PlannedProductionOrder) =
plannedOrder
|> (fun po -> { ProductId = po.ProductId; LocationId = po.LocationId; Quantity = po.Quantity})
|> validateProductionLimit limits
|> Result.bind (createRequirementsForOrder routings)
|> Result.map(plannedOrderToCapacityRequirements plannedOrder)
let collectCapacityRequirements limits routings plannedOrders =
let results =
plannedOrders
|> List.map (planCapacityForOrder limits routings)
let errors =
results
|> List.choose (function
| Error e -> Some e
| Ok _ -> None)
let requirements =
results
|> List.choose (function
| Ok reqs -> Some reqs
| Error _ -> None)
|> List.concat
if List.isEmpty errors then
Ok requirements
else
Error errors
(*
Mature Capacity Planning Concepts
------------------------------------------
Finite capacity scheduling
Alternate routings
Alternate resources
Setup families
Sequence-dependent setup time
Campaign planning
Shift calendars
Downtime calendars
Labor constraints
Material-capacity simultaneous feasibility
Transfer lead times
Transfer capacity
Plant-specific min/max production
Lot sizing
Minimum batch quantity
Maximum batch quantity
Economic order quantity
Shelf-life constraints
Priority allocation
*)
let runCapacityPlanning limits routings buckets plannedOrders =
match collectCapacityRequirements limits routings plannedOrders with
| Error errors ->
{
Requirements = []
Reservations = []
RemainingBuckets = buckets
Shortages = errors
Messages = [ "Capacity planning failed during requirement generation." ]
}
| Ok requirements ->
let reservationState =
reserveCapacityRequirements buckets requirements
{
Requirements = requirements
Reservations = reservationState.Reservations
RemainingBuckets = reservationState.Buckets
Shortages = reservationState.Shortages
Messages = reservationState.Messages
}
(*
let findTransferLane productId fromLocation toLocation (lanes: TransferLane list) =
lanes
|> List.tryFind (fun lane ->
lane.ProductId = productId
&& lane.FromLocation = fromLocation
&& lane.ToLocation = toLocation)
let proposeTransfer lane quantity requiredArrivalDate =
if not lane.IsAllowed then
TransferNotPossible "Transfer lane is not allowed."
else
let shipDate = requiredArrivalDate.AddDays(-lane.TransferLeadTimeDays)
TransferProposed
{
ProductId = lane.ProductId
FromLocation = lane.FromLocation
ToLocation = lane.ToLocation
Quantity = quantity
ShipDate = shipDate
ArrivalDate = requiredArrivalDate
}
*)
module SupplyChain.SharedKernel
open Common.Validator
type ValidationError =
| FieldMissing of fieldName: string
| InvalidPositiveQuantity of fieldName: string * value: decimal
| InvalidNonNegativeQuantity of fieldName: string * value: decimal
| InvalidCode of fieldName: string * value: string
module String =
let requireNonEmpty fieldName value =
if System.String.IsNullOrWhiteSpace value then
Invalid [ FieldMissing fieldName ]
else
Valid value
module Decimal =
let requirePositive fieldName value =
if value > 0M then
Valid value
else
Invalid [ InvalidPositiveQuantity (fieldName, value) ]
let requireNonNegative fieldName value =
if value >= 0M then
Valid value
else
Invalid [ InvalidNonNegativeQuantity (fieldName, value) ]
type Quantity = private Quantity of decimal
module Quantity =
let createPositive value =
value
|> Decimal.requirePositive "Quantity"
|> map Quantity
let createNonNegative value =
value
|> Decimal.requireNonNegative "Quantity"
|> map Quantity
let zero =
Quantity 0M
let value (Quantity x) = x
let add (Quantity a) (Quantity b) =
Quantity (a + b)
let subtract (Quantity a) (Quantity b) =
let result = a - b
if result < 0M then
Error "Quantity cannot become negative."
else
Ok (Quantity result)
let multiplyByDecimal factor (Quantity q) =
Quantity (q * factor)
let multiply (Quantity a) (Quantity b) =
Quantity (a * b)
let isZero q = value q = 0M
let greaterThanZero q = value q > 0M
let lessOrEqual a b = value a <= value b
let minQuantity a b = if value a <= value b then a else b
let subtractUnsafe a b = value a - value b |> createNonNegative
module DomainTypes =
type ProductId = private ProductId of string
type LocationId = private LocationId of string
type CustomerId = private CustomerId of string
type ResourceId = private ResourceId of string
type UomCode = private UomCode of string
module ProductId =
let create value =
value
|> String.requireNonEmpty "ProductId"
|> map ProductId
let value (ProductId x) = x
module LocationId =
let create value =
value
|> String.requireNonEmpty "LocationId"
|> map LocationId
let value (LocationId x) = x
module CustomerId =
let create value =
value
|> String.requireNonEmpty "CustomerId"
|> map CustomerId
let value (CustomerId x) = x
module ResourceId =
let create value =
value
|> String.requireNonEmpty "ResourceId"
|> map ResourceId
let value (ResourceId x) = x
module UomCode =
let create value =
value
|> String.requireNonEmpty "UomCode"
|> map UomCode
let value (UomCode x) = x
Raw
gistfile4.txt
namespace SupplyChain.Application
open System
open SupplyChain.Domain
open SupplyChain.Domain.ResultEx
module Workflow =
type ScenarioConfig = {
RunDate: DateTime
HorizonDays: int
PreferredOnnxModelPath: string option
}
type ResultBuilder() =
member _.Bind(input, binder) = Result.bind binder input
member _.Return(value) = Ok value
member _.ReturnFrom(result) = result
let result = ResultBuilder()
let private buildForecastRequests horizonDays (inventories: InventoryPosition list) demandSeries =
let inventoryByKey =
inventories
|> List.map (fun inventory -> Keys.demandKey inventory.Sku inventory.Location, inventory)
|> Map.ofList
let tryRequest (series: DemandSeries) =
inventoryByKey
|> Map.tryFind (Keys.demandKey series.Sku series.Location)
|> function
| Some inventory -> Ok { Series = series; Inventory = inventory; HorizonDays = horizonDays }
| None ->
Error (DataError (sprintf "Missing inventory for %s/%s" (SkuId.value series.Sku) (LocationId.value series.Location)))
demandSeries
|> List.map tryRequest
|> sequence
let private loadForecasts config deps requests =
match config.PreferredOnnxModelPath with
| Some path ->
deps.ml.tryOnnxForecast path requests
|> Result.bind (function
| Some forecasts -> Ok forecasts
| None -> deps.ml.forecastWithMlNet requests)
| None -> deps.ml.forecastWithMlNet requests
let run config deps =
result {
let! history = deps.data.loadDemandHistory ()
let! inventory = deps.data.loadInventory ()
let! capacities = deps.data.loadCapacities ()
let! demandSeries = deps.analytics.prepareDemandSeries history
let! requests = buildForecastRequests config.HorizonDays inventory demandSeries
let! forecasts = loadForecasts config deps requests
let problem = {
Forecasts = forecasts
Inventories = inventory
Capacities = capacities
}
let! plan = deps.optimization.optimizeReplenishment problem
let notes = [
sprintf "Series prepared: %i" demandSeries.Length
sprintf "Forecasts produced: %i" forecasts.Length
sprintf "Optimization decisions: %i" plan.Decisions.Length
]
return {
RunDate = config.RunDate
Forecasts = forecasts
Plan = plan
Notes = notes
}
}
module PlanningWorkflow =
open SupplyChain.Planning.PlanBuilder
let runSimplePlanning ports =
async {
let! demandResult =
ports.Demand.GetOpenDemand ()
match demandResult with
| Error err ->
return Error (DemandError err)
| Ok demands ->
let! supplyResult =
ports.Supply.GetAvailableSupply ()
match supplyResult with
| Error err ->
return Error (SupplyError err)
| Ok supplies ->
let plan =
buildPlan demands supplies
return Ok plan
}
open SupplyChain.Supply
open SupplyChain.Demand
open SupplyChain.Planning
open SupplyChain.SharedKernel
open Common.Validator
open SupplyChain.MasterData
open SupplyChain.Capacity
type RawPlanningRequest =
{
CustomerOrders: RawCustomerOrder list
Forecasts: RawForecastDemand list
InventoryBalances: RawInventoryBalance list
ProducedSupplies: RawProducedSupply list
PurchaseSupplies: RawPurchaseSupply list
}
type PlanningReferenceData =
{
Products: Product list
Boms: Bom list
Routings: Routing list
Resources: Resource list
CapacityBuckets: CapacityBucket list
ProductionLimits: ProductionLimit list
TransferLanes: TransferLane list
}
type AppError =
| DemandPreparationError of ValidationError list
| SupplyPreparationError of ValidationError list
let preparePlanningInput (request: RawPlanningRequest) =
let demandValidation =
prepareDemand
request.CustomerOrders
request.Forecasts
let supplyValidation =
prepareSupply
request.InventoryBalances
request.ProducedSupplies
request.PurchaseSupplies
let makePlanningInput demands supplies =
{
Demands = demands
Supplies = supplies
PlanningDate = Data.planningDate
HorizonStart = Data.horizonStart
HorizonEnd = Data.horizonEnd
Products = Data.products
Boms = Data.boms
Routings = Data.routings
Resources = Data.resources
CapacityBuckets = Data.capacityBuckets
ProductionLimits = Data.productionLimits
TransferLanes = Data.transferLanes
}: PlanningInput
makePlanningInput
<!> demandValidation
<*> supplyValidation
let preparePlanningInputWithMaterials getBom (planningInput: PlanningInput) =
async {
let! explosionResult =
Materials.explodeAndAggregate getBom planningInput.Demands
match explosionResult with
| Error e -> return Error e
| Ok result ->
return
Ok
{
Demands = planningInput.Demands
Supplies = planningInput.Supplies
MaterialRequirements = result.DetailedRequirements
AggregatedMaterialRequirements = result.AggregatedRequirements
}
}
let preparePlanningInputResult request =
request
|> preparePlanningInput
|> toResult
let runNetting planningInput =
let nettingResult = Netting.runNetting planningInput
let planIdResult: Validation<PlanId,ValidationError> = PlanId.create "PLAN-001"
match planIdResult with
| Valid planId -> Ok (Netting.buildSupplyChainPlan planId nettingResult)
| Invalid _ -> Error "Error while netting"
let runPlanning planningInput =
let nettingResult = Netting.runNetting planningInput
let cplanning = runCapacityPlanning rout
let planIdResult: Validation<PlanId,ValidationError> = PlanId.create "PLAN-001"
match planIdResult with
| Valid planId -> Ok (Netting.buildSupplyChainPlan planId nettingResult)
| Invalid _ -> Error "Error while netting"
namespace SupplyChain.Application
open SupplyChain.Domain
type DataPorts = {
loadDemandHistory: unit -> Result<DemandObservation list, DomainError list>
loadInventory: unit -> Result<InventoryPosition list, DomainError list>
loadCapacities: unit -> Result<SupplierCapacity list, DomainError list>
}
type AnalyticsPorts = {
prepareDemandSeries: DemandObservation list -> Result<DemandSeries list, DomainError list>
}
type MachineLearningPorts = {
tryOnnxForecast: string -> ForecastRequest list -> Result<Forecast list option, DomainError list>
forecastWithMlNet: ForecastRequest list -> Result<Forecast list, DomainError list>
}
type OptimizationPorts = {
optimizeReplenishment: OptimizationProblem -> Result<ReplenishmentPlan, DomainError list>
}
type Dependencies = {
data: DataPorts
analytics: AnalyticsPorts
ml: MachineLearningPorts
optimization: OptimizationPorts
}
open SupplyChain
open SupplyChain.Planning
open SupplyChain.Planning.Ports
open SupplyChain.Planning.PlanBuilder
open SupplyChain.SharedKernel.DomainTypes
open SupplyChain.MasterData
type SupplyChainAppPorts =
{
Demand: DemandPort
Supply: SupplyPort
MasterData: MasterDataPort
Capacity: CapacityPort
}
type AppError =
| DemandError of Demand.DemandError
| SupplyError of Supply.SupplyError
| MasterDataError of MasterData.MasterDataError
| CapacityError of Capacity.CapacityError
| PlanningError of Planning.PlanningError
type MasterDataPort =
{
GetBom :
ProductId -> Async<Result<Bom option, MasterDataError>>
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment